ppad-censor 0.5.2 → 0.6.0

raw patch · 8 files changed

+718/−174 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +28/−0
• lib/Censor.hs +295/−100
• lib/Censor/Meter.hs +50/−3
• lib/Censor/Runner.hs +29/−11
• lib/Censor/Runner/Report.hs +180/−58
• ppad-censor.cabal +1/−1
• run/Main.hs +1/−0
• test/Main.hs +134/−1

@@ -1,5 +1,33 @@ # Changelog +- 0.6.0 (2026-10-16)+  * **Split meter.** `withSplitMeter` (Linux) reads the cycle counter+    and the wall clock over the same execution, and `runSplit` /+    `runSplitWith` test three channels on every pair: cycles, the+    clock period (wall time per cycle, in femtoseconds), and wall+    time. Each channel is a full hedge with its own warmup+    calibration and its own guarantee at `cfgAlpha`; the cycles+    channel stops the run, and its result is the verdict.+    `attributeSplit` runs the A/A and B/B controls once and reads a+    verdict per channel. A secret can move wall time through cycles+    (the code) or through the clock (data-dependent power under+    frequency scaling); the split tells the two apart on the same+    samples.++  * `runTraceSuite` accepts the meter `cycles+wall`+    (`Censor.Runner.splitMeterName`). The case's `result` is the+    cycles channel, and a new per-case `channels` array in the+    report-v3 JSON carries the period and wall channels, each with+    its unit and, on a rejection, its own controls. The controls run+    when any channel rejects. Single-meter reports are unchanged.++  * **Breaking:** `CaseReport` gains `crChannels` (empty under a+    single meter), with `ChannelReport` for its entries.++  * The driver's per-stream state is factored into an internal+    channel shared by `runCTWith` and the split driver. Results are+    unchanged: pinned-seed runs reproduce exactly.+ - 0.5.2 (2026-10-11)   * Supports GHC 9.8, via ppad-eproc 0.5.1. The package description     no longer renders "A/A and B/B" as emphasis on Hackage.

@@ -78,6 +78,12 @@   , Frame(..)   , runCTAttributed +    -- * Split runs+  , Split(..)+  , runSplit+  , runSplitWith+  , attributeSplit+     -- * Batch calibration   , calibrateBatch   , CalibReport(..)@@ -102,6 +108,8 @@   , Counter(..)   , MeterError(..)   , withCounter+  , SplitMeter(..)+  , withSplitMeter      -- * Sampler support (re-exports)   , Rng@@ -583,73 +591,25 @@   validateConfig cfg   (!root, !wSeed, !mSeed) <- resolveSeeds (cfgSeed cfg)   let !samplers = orderedSamplers hyp-  (!c, !qs, !meterResolves, !medR) <- warmup meter cfg hyp samplers wSeed-  unless meterResolves $ throwIO WarmupZeroDuration-  !mdelta <- case cfgMargin cfg of-    Nothing  -> pure Nothing-    Just rel -> do-      let !delta = rel * medR-      unless (delta > 0) $ throwIO $! InvalidConfig-        "cfgMargin resolves to a zero absolute margin (warmup \-        \median reading is 0); raise cfgBatch"-      unless (delta < c) $ throwIO $! InvalidConfig-        "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)"-      pure (Just delta)-  !hcfg <- case mkHedgeCfg (cfgAlpha cfg) c qs mdelta of-    Left  e -> throwIO (InvalidEprocConfig e)-    Right x -> pure x-  !cscfg <- case EPCS.config (negate (hcC3 hcfg)) (hcC3 hcfg)-                   (cfgAlpha cfg) effectGrid of-    Left  e -> throwIO (InvalidEprocConfig e)-    Right x -> pure x-  let !mixc = hcMix hcfg-      finish ctor !n !st !iv !cl = ctor-        n (EPMix.log_evalue_sup mixc (hsMix st))-        (EPMix.p_value mixc (hsMix st))-        iv-        (clAtC cl) (clAt4C cl) (clAt16C cl) c-        (EPSign.log_evalue_sup (hsSign st))-        (EPMagn.log_evalue_sup (hsMagn1 st))-        (EPMagn.log_evalue_sup (hsMagn2 st))-        (EPMagn.log_evalue_sup (hsMagn3 st))-        (cdfPeaks qs (hsCdf st))-        root-        mdelta-      -- 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 finish reports.-      go !n !st !cs !iv !rng !cl-        | n >= cfgBudget cfg =-            pure $! finish Pass n st iv cl+      pair      = runPair meter cfg hyp samplers+  ws  <- warmup cfg pair wSeed+  !ch <- channel cfg [ (fromIntegral x, fromIntegral y) | (x, y) <- ws ]+  let go !n !st !rng+        | n >= cfgBudget cfg = pure $! chanResult ch root n st         | otherwise = do             let (!rng', !bit) = nextOrderBit rng-            (!ta, !tb) <- runPair meter cfg hyp samplers bit-            let !xa      = fromIntegral ta :: Double-                !xb      = fromIntegral tb :: Double-                !d       = xa - xb-                !clipped = abs d > c-                !st'     = updateHedge hcfg st d xa xb-                !cs'     = EPCS.update cscfg cs (clipD (hcC3 hcfg) d)-                !iv'     = case EPCS.interval cscfg cs' of-                             Just x  -> x-                             Nothing -> iv-                !cl'     = bumpClips hcfg cl d-                !n'      = n + 1+            (!ta, !tb) <- pair bit+            let !xa  = fromIntegral ta :: Double+                !xb  = fromIntegral tb :: Double+                !st' = stepChan ch st xa xb+                !n'  = n + 1             -- lazy: the frame's fields (mixture reads) are forced             -- only if the observer forces them, so runCT pays nothing.-            observe (Frame n' d-                       (EPMix.log_evalue mixc (hsMix st'))-                       (EPMix.log_evalue_sup mixc (hsMix st'))-                       (fst iv') (snd iv') clipped)-            case EPMix.decide mixc (hsMix st') of-              EPMix.Reject -> pure $! finish Reject n' st' iv' cl'-              _            -> go n' st' cs' iv' rng' cl'-      !iv0 = (negate (hcC3 hcfg), hcC3 hcfg)-  go 0 (initialHedge hcfg) (EPCS.initial cscfg) iv0 mSeed noClips+            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@@ -673,6 +633,99 @@       pure (r, Just att)     Pass{}   -> pure (r, Nothing) +-- | One value per channel of a split run ('runSplitWith'): a+--   t'Result' each, or the controls' t'Attribution' each.+data Split a = Split+  { splitCycles :: !a+    -- ^ the cycle count: whether the code's execution depends on+    --   the class. The verdict is this channel's.+  , splitPeriod :: !a+    -- ^ wall time per cycle, in femtoseconds: whether the clock the+    --   cycles ran at does.+  , splitWall   :: !a+    -- ^ wall time, in nanoseconds: the two together, as elapsed+    --   time shows them to an observer.+  } deriving (Eq, Show)++instance Functor Split where+  fmap f (Split c p w) = Split (f c) (f p) (f 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 meter cfg hyp observe = do+  validateConfig cfg+  (!root, !wSeed, !mSeed) <- resolveSeeds (cfgSeed cfg)+  let !samplers = orderedSamplers hyp+      pair      = runSplitPair meter cfg hyp samplers+  ws <- warmup cfg pair wSeed+  let rs = fmap splitReadings ws+  !cc <- channel cfg (fmap splitCycles rs)+  !cp <- channel cfg (fmap splitPeriod rs)+  !cw <- channel cfg (fmap splitWall rs)+  let finish !n !sc !sp !sw = Split+        (chanResult cc root n sc)+        (chanResult cp root n sp)+        (chanResult cw root n sw)+      go !n !sc !sp !sw !rng+        | n >= cfgBudget cfg = pure $! finish n sc sp sw+        | otherwise = do+            let (!rng', !bit) = nextOrderBit rng+            !r <- pair bit+            case splitReadings r of+              Split (!ca, !cb) (!pa, !pb) (!wa, !wb) -> do+                let !sc' = stepChan cc sc ca cb+                    !sp' = stepChan cp sp pa pb+                    !sw' = stepChan cw sw wa wb+                    !n'  = n + 1+                observe (chanFrame cc n' (ca - cb) sc')+                if chanRejects cc sc'+                  then pure $! finish n' sc' sp' sw'+                  else go n' sc' sp' sw' 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 meter cfg hyp = runSplitWith meter cfg hyp (\_ -> 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 meter cfg hyp = do+  Split ac ap aw <- runSplit meter cfg (toAA 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,@@ -895,16 +948,21 @@ attribute meter cfg hyp = do   raa <- runAA meter cfg hyp   rbb <- runBB meter cfg hyp+  pure $! attribution raa rbb++-- the controls' combined verdict, carrying both runs.+attribution :: Result -> Result -> Attribution+attribution raa rbb =   let !v = case (raa, rbb) of         (Pass{},   Pass{})   -> ControlsPass         (Reject{}, Pass{})   -> SampleAAsymmetry         (Pass{},   Reject{}) -> SampleBAsymmetry         (Reject{}, Reject{}) -> PervasiveAsymmetry-  pure $! Attribution-    { attVerdict = v-    , attAA      = raa-    , attBB      = rbb-    }+  in  Attribution+        { attVerdict = v+        , attAA      = raa+        , attBB      = rbb+        }  -- internal @@ -955,16 +1013,51 @@   !t1 <- measure meter (cfgBatch cfg) (target hyp u)   !v  <- indexSmallArray samplers iSnd   !t2 <- measure meter (cfgBatch cfg) (target hyp v)-  -- branchless unscramble: swap iff bit = 1, via an all-ones mask.-  -- x is class A's reading (slot 1 when the bit is 0, slot 2 when-  -- it is 1), y class B's.-  let !m = negate bit-      !s = (t1 `B.xor` t2) B..&. m-      !x = t1 `B.xor` s-      !y = t2 `B.xor` s+  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 meter cfg hyp samplers !bit = do+  prepare hyp+  let !iFst = fromIntegral bit :: Int+      !iSnd = 1 - iFst+  !u <- indexSmallArray samplers 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 !bit !t1 !t2 =+  let !m = negate bit+      !s = (t1 `B.xor` t2) B..&. m+  in  (t1 `B.xor` s, t2 `B.xor` 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 (!ca, !wa, !cb, !wb) = Split+  (fromIntegral ca, fromIntegral cb)+  (period wa ca, period wb cb)+  (fromIntegral wa, fromIntegral wb)+  where+    period !w !c = fromIntegral w * 1.0e6 / fromIntegral (max 1 c)+ -- The hedge composition ----------------------------------------------------  -- The components are heterogeneous, so the driver steps each one@@ -1037,6 +1130,109 @@     , 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+  { chHedge :: !HedgeCfg+  , chSeq   :: !EPCS.Config+  }++data ChanState = ChanState+  { csHedge :: !HedgeState+  , csSeq   :: !EPCS.State+  , csIv    :: !(Double, Double)  -- the latched effect interval+  , 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 cfg ws = do+  let (!c, !qs, !meterResolves, !medR) = calibrate ws+  unless meterResolves $ throwIO WarmupZeroDuration+  !mdelta <- case cfgMargin cfg of+    Nothing  -> pure Nothing+    Just rel -> do+      let !delta = rel * medR+      unless (delta > 0) $ throwIO $! InvalidConfig+        "cfgMargin resolves to a zero absolute margin (warmup \+        \median reading is 0); raise cfgBatch"+      unless (delta < c) $ throwIO $! InvalidConfig+        "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)"+      pure (Just delta)+  !hcfg <- case mkHedgeCfg (cfgAlpha cfg) c qs mdelta of+    Left  e -> throwIO (InvalidEprocConfig e)+    Right x -> pure x+  !cscfg <- case EPCS.config (negate (hcC3 hcfg)) (hcC3 hcfg)+                   (cfgAlpha cfg) effectGrid of+    Left  e -> throwIO (InvalidEprocConfig e)+    Right x -> pure x+  pure (Chan hcfg cscfg)++chanInitial :: Chan -> ChanState+chanInitial Chan{..} = ChanState+  { csHedge = initialHedge chHedge+  , csSeq   = EPCS.initial chSeq+  , csIv    = (negate (hcC3 chHedge), hcC3 chHedge)+  , csClips = 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{..} !xa !xb =+  let !d   = xa - xb+      !h'  = updateHedge chHedge csHedge d xa xb+      !s'  = EPCS.update chSeq csSeq (clipD (hcC3 chHedge) d)+      !iv' = case EPCS.interval chSeq s' of+               Just x  -> x+               Nothing -> csIv+      !cl' = bumpClips chHedge csClips d+  in  ChanState h' s' iv' cl'++-- Whether the channel's mixture has crossed its threshold; latched.+chanRejects :: Chan -> ChanState -> Bool+chanRejects Chan{..} ChanState{..} =+  case EPMix.decide (hcMix chHedge) (hsMix csHedge) of+    EPMix.Reject -> True+    _            -> False++-- The channel's frame after pair @n@, whose difference was @d@.+chanFrame :: Chan -> Int -> Double -> ChanState -> Frame+chanFrame Chan{..} !n !d ChanState{..} = Frame n d+  (EPMix.log_evalue mixc (hsMix csHedge))+  (EPMix.log_evalue_sup mixc (hsMix csHedge))+  (fst csIv) (snd csIv)+  (abs d > hcC1 chHedge)+  where+    mixc = hcMix chHedge++-- The channel's t'Result' after @n@ pairs, under the run's root seed.+chanResult :: Chan -> Word64 -> Int -> ChanState -> Result+chanResult ch@Chan{..} !root !n st@ChanState{..} = ctor+  n (EPMix.log_evalue_sup mixc (hsMix csHedge))+  (EPMix.p_value mixc (hsMix csHedge))+  csIv+  (clAtC csClips) (clAt4C csClips) (clAt16C csClips) (hcC1 chHedge)+  (EPSign.log_evalue_sup (hsSign csHedge))+  (EPMagn.log_evalue_sup (hsMagn1 csHedge))+  (EPMagn.log_evalue_sup (hsMagn2 csHedge))+  (EPMagn.log_evalue_sup (hsMagn3 csHedge))+  (cdfPeaks (hcQs chHedge) (hsCdf csHedge))+  root+  (hcMargin chHedge)+  where+    mixc = hcMix chHedge+    ctor | chanRejects ch st = Reject+         | otherwise         = 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.@@ -1191,7 +1387,19 @@       | otherwise         = Nothing     step !acc !w = acc * 256 + fromIntegral w --- Warmup: run @cfgWarmup@ randomly ordered pairs and return+-- 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 cfg pair = go 0 []+  where+    go !i !acc !rng+      | i >= cfgWarmup cfg = pure acc+      | otherwise = do+          let (!rng', !bit) = nextOrderBit rng+          !r <- pair 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@@ -1206,28 +1414,17 @@ --     throws 'WarmupZeroDuration'. --   * @medReading@, the pooled median, which resolves a relative --     'cfgMargin'.-warmup-  :: Meter -> Config -> Hypothesis a -> SmallArray (IO a) -> Word64-  -> IO (Double, [Double], Bool, Double)-warmup meter cfg hyp samplers seed = do-  let go !i !rng !accD !accR-        | i >= cfgWarmup cfg = pure (accD, accR)-        | otherwise = do-            let (!rng', !bit) = nextOrderBit rng-            (!x, !y) <- runPair meter cfg hyp samplers bit-            let !dx = fromIntegral x :: Double-                !dy = fromIntegral y :: Double-                !da = abs (dx - dy)-            go (i + 1) rng' (da : accD) (x : y : accR)-  (diffs, readings) <- go 0 seed [] []-  let !sortedR = sort readings-      !p99d    = orderStat99 diffs-      !p99r    = orderStat99 readings-      !qs      = cutPoints sortedR-      !medR    = fromIntegral (nth (length sortedR `div` 2) sortedR)+calibrate :: [(Double, Double)] -> (Double, [Double], Bool, Double)+calibrate ws =+  let !readings = concat [ [x, y] | (x, y) <- ws ]+      !sortedR  = sort readings+      !p99d     = orderStat99 [ abs (x - y) | (x, y) <- ws ]+      !p99r     = orderStat99 readings+      !qs       = cutPoints sortedR+      !medR     = nth (length sortedR `div` 2) sortedR   -- twice the order statistic leaves headroom for occasional   -- outliers; larger differences are clipped in the main phase.-  pure (max 1 (2 * p99d), qs, p99r > 0, medR)+  in  (max 1 (2 * p99d), qs, p99r > 0, medR)  -- Empirical @~p99@ order statistic. Sorts and picks index -- @(m * 99) \/ 100@; degenerates to the sample max at small @m@@@ -1251,15 +1448,13 @@ -- Nearest-rank order statistics of a sorted reading list at -- 'cdfLevels', ascending and deduplicated. Empty when warmup -- collected nothing.-cutPoints :: [Word64] -> [Double]+cutPoints :: [Double] -> [Double] cutPoints sorted   | m == 0    = []   | otherwise = dedupAsc (map pick cdfLevels)   where     !m = length sorted-    pick !p =-      fromIntegral (nth (max 0 (min (m - 1) (floor (p * fromIntegral m))))-                        sorted)+    pick !p = nth (max 0 (min (m - 1) (floor (p * fromIntegral m)))) sorted  -- Drop repeats from an ascending list. dedupAsc :: [Double] -> [Double]

@@ -17,7 +17,9 @@ -- properties of the executed code, immune to the frequency, cache, -- and scheduling noise that limits the wall clock on fast targets, -- while the other counters help attribute a difference to a channel--- (see t'Counter').+-- (see t'Counter'). 'withSplitMeter' reads the cycle counter and the+-- wall clock over the same execution, splitting wall time into the+-- cycles the code took and the clock period they ran at.  module Censor.Meter (     -- * Meter type@@ -30,6 +32,10 @@   , Counter(..)   , MeterError(..)   , withCounter++    -- * Wall time split into cycles and period (Linux)+  , SplitMeter(..)+  , withSplitMeter   ) where  import Control.Exception (Exception, throwIO)@@ -52,6 +58,17 @@   { measure :: Int -> IO () -> IO Word64   } +-- | A meter reading two quantities over one execution of the batch:+--   @'measureSplit' m k act@ returns @(cycles, nanoseconds)@. Wall+--   time is cycles times the clock period, and a secret can move it+--   through either factor: through cycles when the code's execution+--   depends on it, through the period when the core's frequency+--   does (data-dependent power under frequency scaling). Reading+--   both on the same execution tells the two apart.+newtype SplitMeter = SplitMeter+  { measureSplit :: Int -> IO () -> IO (Word64, Word64)+  }+ -- | Wall-clock meter: elapsed nanoseconds over the batch. -- --   On Darwin, backed by @clock_gettime_nsec_np(CLOCK_UPTIME_RAW)@,@@ -164,11 +181,26 @@ --   to a user-only clock. A counter is bound to the thread that --   opened it, so the callback runs on one OS thread. withCounter :: Counter -> (Meter -> IO a) -> IO a-withCounter counter k = onOneThread $ do+withCounter counter k = withPerf counter (k . meterFor)++-- | Acquire a t'SplitMeter' for the duration of the callback, then+--   release it. Throws 'MeterError' if the cycle counter cannot be+--   opened.+--+--   The wall clock is read inside the counted region, so both+--   readings cover the batch and the clock reads; the overhead is+--   the same in both classes. As with 'withCounter', the callback+--   runs on one OS thread.+withSplitMeter :: (SplitMeter -> IO a) -> IO a+withSplitMeter k = withPerf Cycles (k . splitFor)++-- open a counter on one OS thread for the callback, closing it after.+withPerf :: Counter -> (CInt -> IO a) -> IO a+withPerf counter k = onOneThread $ do   fd <- c_perf_open (counterCode counter)   if fd < 0     then throwIO (OpenFailed (negate (fromIntegral fd)))-    else k (meterFor fd) `finally` c_perf_close fd+    else k fd `finally` c_perf_close fd   where     -- the perf fd is thread-affine; keep open + measures on one OS     -- thread. runInBoundThread requires the threaded RTS, so fall back@@ -184,11 +216,26 @@   c_perf_end fd {-# INLINE meterFor #-} +splitFor :: CInt -> SplitMeter+splitFor !fd = SplitMeter $ \k act -> do+  c_perf_begin fd+  !t0 <- monotonicNS+  rep k act+  !t1 <- monotonicNS+  !cy <- c_perf_end fd+  pure (cy, t1 - t0)+{-# INLINE splitFor #-}+ #else  -- | Hardware performance-counter meters are only available on Linux; --   on other platforms this always throws 'Unsupported'. withCounter :: Counter -> (Meter -> IO a) -> IO a withCounter _ _ = throwIO Unsupported++-- | The split meter needs the cycle counter, so it is only available+--   on Linux; on other platforms this always throws 'Unsupported'.+withSplitMeter :: (SplitMeter -> IO a) -> IO a+withSplitMeter _ = throwIO Unsupported  #endif

@@ -18,6 +18,8 @@   , parseMeter   , meterName   , withMeterArg+  , splitMeterName+  , withSplitMeterArg      -- * Recording traces   , Trace(..)@@ -92,17 +94,33 @@       case r of         Right a -> pure a         Left e  -> die $ name ++ " meter unavailable: "-          ++ show (e :: MeterError) ++ hint e-  where-    -- EPERM/EACCES means the kernel refused a counter that exists,-    -- which for an unprivileged process is the paranoid level.-    -- task-clock counts kernel time and so needs a lower one than-    -- the rest; see Censor.Meter.-    hint (OpenFailed n)-      | n == 1 || n == 13 =-          " (check kernel.perf_event_paranoid: task-clock needs 1"-            ++ " or lower, the other counters 2 or lower)"-    hint _ = ""+          ++ show (e :: MeterError) ++ paranoidHint e++-- | The split meter's name on the command line and in reports+--   (@cycles+wall@; see 'withSplitMeter').+splitMeterName :: String+splitMeterName = "cycles+wall"++-- | Run the callback with a t'SplitMeter', dying with a clear message+--   if the cycle counter cannot be opened, as 'withMeterArg' does.+withSplitMeterArg :: (SplitMeter -> IO a) -> IO a+withSplitMeterArg k = do+  r <- try (withSplitMeter k)+  case r of+    Right a -> pure a+    Left e  -> die $ splitMeterName ++ " meter unavailable: "+      ++ show (e :: MeterError) ++ paranoidHint e++-- EPERM/EACCES means the kernel refused a counter that exists, which+-- for an unprivileged process is the paranoid level. task-clock+-- counts kernel time and so needs a lower one than the rest; see+-- Censor.Meter.+paranoidHint :: MeterError -> String+paranoidHint (OpenFailed n)+  | n == 1 || n == 13 =+      " (check kernel.perf_event_paranoid: task-clock needs 1"+        ++ " or lower, the other counters 2 or lower)"+paranoidHint _ = ""  -- recording ------------------------------------------------------------------- 

@@ -34,6 +34,7 @@     -- * Data model   , ReportHeader(..)   , CaseReport(..)+  , ChannelReport(..)   , BatteryTail(..)      -- * Renderers@@ -88,6 +89,7 @@ import Censor.Runner   ( traceResult, traceFrames, record, thin   , verdictName, shapeName, clipText, withMeterArg+  , splitMeterName, withSplitMeterArg   ) import Censor.Runner.Env (Env(..), captureEnv) import qualified Paths_ppad_censor as Paths@@ -181,8 +183,25 @@     -- ^ per-pair 'Frame' trajectory, when the runner recorded one     --   (via 'record'). Surfaces in the JSON artefact as a thinned     --   array; the human renderers ignore it.+  , crChannels    :: ![ChannelReport]+    -- ^ further channels read on the case's own pairs and reported+    --   beside its verdict: the period and wall channels of a split+    --   run ('Censor.runSplitWith'), whose 'crResult' is the cycles+    --   channel. Empty under a single meter.   } deriving Show +-- | A channel reported beside a case's verdict.+data ChannelReport = ChannelReport+  { chName        :: !String+    -- ^ channel name (@period@, @wall@).+  , chUnit        :: !String+    -- ^ the unit of its readings (@fs@ per cycle, @ns@).+  , chResult      :: !Result+    -- ^ the channel's own test over the case's pairs.+  , chAttribution :: !(Maybe Attribution)+    -- ^ the channel's A\/A + B\/B controls, on a rejection.+  } deriving Show+ -- | The tail passed to a renderer's 'rndClose'. Carries the --   accumulated case list and, optionally, the path to a companion --   artefact (a trace JSON, a log) that the tool wrote alongside.@@ -423,10 +442,28 @@       Pass{} -> []   , maybe [] pure (calibText cr)   , maybe [] (pure . attributionText) (crAttribution cr)+  , concatMap channelLines (crChannels cr)   ]   where     r = crResult cr +-- a reported-beside channel's lines: its verdict, evidence, and+-- effect interval in its own unit, the driver on a rejection, and+-- its controls when they ran.+channelLines :: ChannelReport -> [String]+channelLines ch =+  printf "%s %s peakLogW=%.2f p=%.2g effect=[%.1f,%.1f] %s%s"+    (chName ch) (verdictName r) (resPeakLogW r) (resPValue r)+    elo ehi (chUnit ch) drv+  : maybe [] (pure . ((chName ch ++ " ") ++) . attributionText)+      (chAttribution ch)+  where+    r = chResult ch+    (elo, ehi) = resEffect r+    drv = case r of+      Reject{} -> " driver=" ++ shapeName (leakShape r)+      Pass{}   -> ""+ -- the run-metadata line under a case row: resolved batch, the -- meter's noise floor at that batch when recorded, the target's -- baseline cost when probed, and the order seed the run resolved@@ -511,6 +548,11 @@ --   @orderSeed@ inside each case result is the resolved per-run --   A\/B order seed that replays that case. --+--   A split run's case carries a @channels@ array: the period and+--   wall channels read on its own pairs, each with its name, unit,+--   result, and controls on a rejection. The case's @result@ is the+--   cycles channel, which carries the verdict.+-- --   The 'json' renderer and 'runTraceSuite' both call this so --   stdout output and the on-disk artefact are byte-identical. reportJSON :: ReportHeader -> [CaseReport] -> String@@ -585,10 +627,24 @@   , ",\"result\":", resultToJSON (crResult cr)   , maybe "" (\a -> ",\"controls\":" ++ controlsJSON a)       (crAttribution cr)+  , case crChannels cr of+      []  -> ""+      chs -> ",\"channels\":["+        ++ intercalate "," (map channelJSON chs) ++ "]"   , maybe "" (\frs -> ",\"trace\":" ++ traceArrayJSON frs) (crTrace cr)   , "}"   ] +channelJSON :: ChannelReport -> String+channelJSON ch = concat+  [ "{\"name\":",   jstr (chName ch)+  , ",\"unit\":",   jstr (chUnit ch)+  , ",\"result\":", resultToJSON (chResult ch)+  , maybe "" (\a -> ",\"controls\":" ++ controlsJSON a)+      (chAttribution ch)+  , "}"+  ]+ -- | Serialise a t'Result' as a stable JSON object. Includes verdict, --   pairs, mixture peak log e-value, anytime-valid p-value, effect --   interval, clip counts at each of the three magnitude bounds,@@ -931,6 +987,13 @@ --   even for pure targets), 'record' streams the run and keeps its --   frames, and on 'Reject' 'attribute' runs the A\/A + B\/B --   diagnostics automatically (two extra runs).+--+--   The meter @cycles+wall@ ('splitMeterName') runs each case under+--   the split meter ('Censor.runSplitWith'): the case's result is+--   the cycles channel, and the period and wall channels of the same+--   pairs are reported beside it ('crChannels'). Calibration and the+--   baseline read cycles, and the controls run when any channel+--   rejects. runTraceSuite :: TraceSuite -> IO () runTraceSuite ts = do   hSetBuffering stdout LineBuffering@@ -943,62 +1006,121 @@   let out = case saExtra sa of         (o:_) -> Just o         _     -> Nothing-  withMeterArg (saMeter sa) $ \mname meter -> do-    env <- captureEnv-    let cfgBase = (tsConfig ts)-          { cfgMargin =-              maybe (cfgMargin (tsConfig ts)) Just (saMargin sa) }-        hdr = ReportHeader-          { rhMeter     = mname-          , rhConfig    = cfgBase-              { cfgBatch = fromMaybe (cfgBatch cfgBase) (saBatch sa) }-          , rhSeed      = tsSeed ts-          , rhTarget    = Just (tsTarget ts)-          , rhNote      = tsNote ts-          , rhEnv       = Just env-          , rhPerCaseBatch = maybe True (const False) (saBatch sa)-          }-        path = fromMaybe (prog ++ "-" ++ mname ++ ".json") out-    ref <- newIORef ([] :: [CaseReport])-    _ <- withReport rc (saRenderer sa) hdr $ \emit -> do-      forM_ (tsCases ts) $ \(TraceCase name policy mkH) -> do-        -- --batch overrides every case's policy; otherwise the-        -- case's own declared policy governs, and only-        -- RepeatableAuto runs a calibration probe.-        ---        -- Each probe gets its own instance: it runs a prologue and-        -- class-A draws, and the main run should start from the-        -- same state whether or not any probe happened.-        (b, mnoise) <- case maybe policy FixedBatch (saBatch sa) of-          SingleShot     -> pure (1, Nothing)-          FixedBatch n   -> pure (n, Nothing)-          RepeatableAuto -> do-            hCal <- mkH-            cb   <- calibrateBatchReport meter hCal-            pure (C.crBatch cb, C.crNoise cb)-        let c = cfgBase { cfgBatch = b }-        hBase <- mkH-        base  <- baselineReading meter c hBase-        h <- mkH-        t <- record name mname meter c h-        let r = traceResult t-        mat <- case r of-          Reject{} -> do-            hAtt <- mkH-            Just <$> attribute meter c hAtt-          Pass{}   -> pure Nothing-        let cr = CaseReport-              { crName        = name-              , crResult      = r-              , crAttribution = mat-              , crBatch       = Just b-              , crNoise       = mnoise-              , crBaseline    = Just base-              , crTrace       = Just (traceFrames t)+      suite mname runCase = do+        env <- captureEnv+        let cfgBase = (tsConfig ts)+              { cfgMargin =+                  maybe (cfgMargin (tsConfig ts)) Just (saMargin sa) }+            hdr = ReportHeader+              { rhMeter     = mname+              , rhConfig    = cfgBase+                  { cfgBatch = fromMaybe (cfgBatch cfgBase) (saBatch sa) }+              , rhSeed      = tsSeed ts+              , rhTarget    = Just (tsTarget ts)+              , rhNote      = tsNote ts+              , rhEnv       = Just env+              , rhPerCaseBatch = maybe True (const False) (saBatch sa)               }-        modifyIORef' ref (cr :)-        emit cr-      cases <- fmap reverse (readIORef ref)-      writeFile path (reportJSON hdr cases)-      pure (Just path)-    pure ()+            path = fromMaybe (prog ++ "-" ++ mname ++ ".json") out+        ref <- newIORef ([] :: [CaseReport])+        _ <- withReport rc (saRenderer sa) hdr $ \emit -> do+          forM_ (tsCases ts) $ \tc -> do+            cr <- runCase cfgBase (saBatch sa) tc+            modifyIORef' ref (cr :)+            emit cr+          cases <- fmap reverse (readIORef ref)+          writeFile path (reportJSON hdr cases)+          pure (Just path)+        pure ()+  case saMeter sa of+    Just m | m == splitMeterName ->+      withSplitMeterArg (suite splitMeterName . splitCase)+    marg -> withMeterArg marg $ \mname meter ->+      suite mname (meterCase mname meter)++-- One case under a single meter: the batch, the baseline, the+-- recorded run, and the controls on a rejection.+meterCase :: String -> Meter -> Config -> Maybe Int -> TraceCase+          -> IO CaseReport+meterCase mname meter cfgBase mbatch (TraceCase name policy mkH) = do+  (b, mnoise) <- caseBatch meter mbatch policy mkH+  let c = cfgBase { cfgBatch = b }+  hBase <- mkH+  base  <- baselineReading meter c hBase+  h <- mkH+  t <- record name mname meter c h+  let r = traceResult t+  mat <- case r of+    Reject{} -> do+      hAtt <- mkH+      Just <$> attribute meter c hAtt+    Pass{}   -> pure Nothing+  pure CaseReport+    { crName        = name+    , crResult      = r+    , crAttribution = mat+    , crBatch       = Just b+    , crNoise       = mnoise+    , crBaseline    = Just base+    , crTrace       = Just (traceFrames t)+    , crChannels    = []+    }++-- One case under the split meter: as 'meterCase', with the cycles+-- channel as the case's result (batch, noise, and baseline are in+-- cycles too) and the period and wall channels beside it. The+-- controls run when any channel rejects, and each rejecting channel+-- carries its own.+splitCase :: SplitMeter -> Config -> Maybe Int -> TraceCase+          -> IO CaseReport+splitCase meter cfgBase mbatch (TraceCase name policy mkH) = do+  let cyc = Meter (\k act -> fmap fst (measureSplit meter k act))+  (b, mnoise) <- caseBatch cyc mbatch policy mkH+  let c = cfgBase { cfgBatch = b }+  hBase <- mkH+  base  <- baselineReading cyc c hBase+  h   <- mkH+  ref <- newIORef []+  sp  <- runSplitWith meter c h $ \ !fr -> modifyIORef' ref (fr :)+  frs <- fmap reverse (readIORef ref)+  matt <- if any isReject [splitCycles sp, splitPeriod sp, splitWall sp]+    then do+      hAtt <- mkH+      Just <$> attributeSplit meter c hAtt+    else pure Nothing+  let ctl r a+        | isReject r = a+        | otherwise  = Nothing+      chan nm unit r a = ChannelReport nm unit r (ctl r a)+  pure CaseReport+    { crName        = name+    , crResult      = splitCycles sp+    , crAttribution = ctl (splitCycles sp) (fmap splitCycles matt)+    , crBatch       = Just b+    , crNoise       = mnoise+    , crBaseline    = Just base+    , crTrace       = Just frs+    , crChannels    =+        [ chan "period" "fs" (splitPeriod sp) (fmap splitPeriod matt)+        , chan "wall" "ns" (splitWall sp) (fmap splitWall matt)+        ]+    }++-- A case's batch, and the meter's noise floor at it when calibrated.+-- --batch overrides every case's policy; otherwise the case's own+-- declared policy governs, and only RepeatableAuto runs a+-- calibration probe.+--+-- Each probe gets its own instance: it runs a prologue and class-A+-- draws, and the main run should start from the same state whether+-- or not any probe happened.+caseBatch+  :: Meter -> Maybe Int -> BatchPolicy -> IO (Hypothesis a)+  -> IO (Int, Maybe Noise)+caseBatch meter mbatch policy mkH = case maybe policy FixedBatch mbatch of+  SingleShot     -> pure (1, Nothing)+  FixedBatch n   -> pure (n, Nothing)+  RepeatableAuto -> do+    hCal <- mkH+    cb   <- calibrateBatchReport meter hCal+    pure (C.crBatch cb, C.crNoise cb)

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               ppad-censor-version:            0.5.2+version:            0.6.0 synopsis:           Anytime-valid sequential constant-time testing. license:            MIT license-file:       LICENSE

@@ -454,6 +454,7 @@     , Rep.crNoise       = Nothing     , Rep.crBaseline    = Just base     , Rep.crTrace       = mfrs+    , Rep.crChannels    = []     }   where     withHyp k = mk >>= \fh -> F.withFFIHypothesis fh k

@@ -29,6 +29,7 @@   , configValidationTests   , deterministicLeakTests   , runCTWithTests+  , splitTests   , evidenceTests   , offByOneTests   , clipCountTests@@ -311,6 +312,135 @@           "expected InvalidConfig, got " ++ show other         Right _ -> assertFailure "expected InvalidConfig" +-- A split meter over synthetic readings: the target writes its+-- class's (base cycles, picoseconds per cycle) into the ref, and each+-- batch reads the base plus class-blind noise from a fixed-seed+-- stream, with wall time the noisy cycles at that period plus a+-- small noisy overhead.+synthSplit :: IO (C.SplitMeter, IORef (Word64, Word64))+synthSplit = do+  g   <- C.mkRng 0x5EED+  ref <- newIORef (0, 0)+  let m = C.SplitMeter $ \k act -> do+        let go 0 = pure ()+            go i = act >> go (i - 1 :: Int)+        go k+        (cy0, ps) <- readIORef ref+        w <- C.nextWord g+        let !cy = cy0 + w `mod` 64+            !ns = cy * ps `div` 1000 + (w `div` 64) `mod` 4+        pure (cy, ns)+  pure (m, ref)++splitHyp+  :: IORef (Word64, Word64) -> (Word64, Word64) -> (Word64, Word64)+  -> C.Hypothesis (Word64, Word64)+splitHyp ref a b = C.Hypothesis+  { C.target  = writeIORef ref+  , C.prepare = pure ()+  , C.sampleA = pure a+  , C.sampleB = pure b+  }++splitCfg :: C.Config+splitCfg = C.defaultConfig+  { C.cfgAlpha  = 1.0e-4+  , C.cfgBudget = 3000+  , C.cfgWarmup = 150+  , C.cfgSeed   = Just 0xABCDEF+  }++isPass :: C.Result -> Bool+isPass C.Pass{}   = True+isPass C.Reject{} = False++splitTests :: TestTree+splitTests = testGroup "split meter" [+    testCase "a clock that follows the class: period and wall reject, \+             \cycles pass" $ do+      (m, ref) <- synthSplit+      sp <- C.runSplit m splitCfg+              (splitHyp ref (1000, 1020) (1000, 1000))+      assertBool ("cycles: " ++ show (C.splitCycles sp))+        (isPass (C.splitCycles sp))+      assertBool ("period: " ++ show (C.splitPeriod sp))+        (not (isPass (C.splitPeriod sp)))+      assertBool ("wall: " ++ show (C.splitWall sp))+        (not (isPass (C.splitWall sp)))+      C.resPairs (C.splitCycles sp) @?= C.cfgBudget splitCfg++  , testCase "a cycles leak stops the run for every channel" $ do+      (m, ref) <- synthSplit+      sp <- C.runSplit m splitCfg+              (splitHyp ref (1100, 1000) (1000, 1000))+      assertBool ("cycles: " ++ show (C.splitCycles sp))+        (not (isPass (C.splitCycles sp)))+      let ns = fmap C.resPairs sp+      assertBool ("stopped early: " ++ show ns)+        (C.splitCycles ns < C.cfgBudget splitCfg)+      C.splitPeriod ns @?= C.splitCycles ns+      C.splitWall ns @?= C.splitCycles ns++  , testCase "the period channel reads femtoseconds per cycle" $ do+      (m, ref) <- synthSplit+      sp <- C.runSplit m splitCfg+              (splitHyp ref (1000, 1020) (1000, 1000))+      -- class A's clock is 20 ps per cycle slower: 2e4 fs+      let (lo, hi) = C.resEffect (C.splitPeriod sp)+      assertBool ("period effect " ++ show (lo, hi))+        (lo < 2.0e4 && 2.0e4 < hi + 2.0e3 && lo > 1.0e4)++  , testCase "frames are the cycles channel's" $ do+      (m, ref) <- synthSplit+      fr <- newIORef (0 :: Int)+      sp <- C.runSplitWith m splitCfg+              (splitHyp ref (1100, 1000) (1000, 1000))+              (\_ -> modifyIORef' fr (+ 1))+      n <- readIORef fr+      n @?= C.resPairs (C.splitCycles sp)++  , testCase "controls carry a verdict per channel" $ do+      (m, ref) <- synthSplit+      att <- C.attributeSplit m splitCfg+               (splitHyp ref (1000, 1020) (1000, 1000))+      fmap C.attVerdict att @?=+        C.Split C.ControlsPass C.ControlsPass C.ControlsPass++  , testCase "unavailable off Linux" $+      if Info.os == "linux"+        then pure ()+        else do+          r <- try (C.withSplitMeter (\_ -> pure ()))+          case r of+            Left C.Unsupported -> pure ()+            other -> assertFailure ("expected Unsupported, got "+              ++ show other)++  , testCase "report JSON carries the channels beside the result" $ do+      (m, ref) <- synthSplit+      sp <- C.runSplit m splitCfg+              (splitHyp ref (1000, 1020) (1000, 1000))+      let hdr = Rep.ReportHeader+            { Rep.rhMeter     = R.splitMeterName+            , Rep.rhConfig    = splitCfg+            , Rep.rhSeed      = Nothing+            , Rep.rhTarget    = Nothing+            , Rep.rhNote      = Nothing+            , Rep.rhEnv       = Nothing+            , Rep.rhPerCaseBatch = False+            }+          cr = Rep.CaseReport "case" (C.splitCycles sp) Nothing+                 Nothing Nothing Nothing Nothing+                 [ Rep.ChannelReport "period" "fs" (C.splitPeriod sp)+                     Nothing ]+          j  = Rep.reportJSON hdr [cr]+      assertBool ("meter in " ++ j)+        ("\"meter\":\"cycles+wall\"" `isInfixOf` j)+      assertBool ("channels in " ++ j)+        ("\"channels\":[{\"name\":\"period\",\"unit\":\"fs\",\+         \\"result\":{\"verdict\":\"REJECT\"" `isInfixOf` j)+  ]+ -- deterministic A/B divergence via a meter that reports state the -- target wrote during the timed region. No wall-clock noise: every -- pair lands the same delta into the wealth process and rejection is@@ -1302,6 +1432,7 @@             , Rep.crNoise       = Just (C.Noise 100 5)             , Rep.crBaseline    = Just (C.Noise 41000 12)             , Rep.crTrace       = Nothing+            , Rep.crChannels    = []             }           j = Rep.reportJSON hdr [cr]       assertBool ("expected env block in " ++ j)@@ -1325,10 +1456,12 @@             , Rep.rhPerCaseBatch = False             }           cr = Rep.CaseReport "case" r Nothing Nothing Nothing Nothing-                 Nothing+                 Nothing []           j  = Rep.reportJSON hdr [cr]       assertBool ("unexpected env block in " ++ j)         (not ("\"env\":" `isInfixOf` j))+      assertBool ("unexpected channels in " ++ j)+        (not ("\"channels\":" `isInfixOf` j))       assertBool ("unexpected noise in " ++ j)         (not ("\"noise\":" `isInfixOf` j))       assertBool ("unexpected baseline in " ++ j)