diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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. diff --git a/lib/Censor.hs b/lib/Censor.hs --- a/lib/Censor.hs +++ b/lib/Censor.hs @@ -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] diff --git a/lib/Censor/Meter.hs b/lib/Censor/Meter.hs --- a/lib/Censor/Meter.hs +++ b/lib/Censor/Meter.hs @@ -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 diff --git a/lib/Censor/Runner.hs b/lib/Censor/Runner.hs --- a/lib/Censor/Runner.hs +++ b/lib/Censor/Runner.hs @@ -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 ------------------------------------------------------------------- diff --git a/lib/Censor/Runner/Report.hs b/lib/Censor/Runner/Report.hs --- a/lib/Censor/Runner/Report.hs +++ b/lib/Censor/Runner/Report.hs @@ -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) diff --git a/ppad-censor.cabal b/ppad-censor.cabal --- a/ppad-censor.cabal +++ b/ppad-censor.cabal @@ -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 diff --git a/run/Main.hs b/run/Main.hs --- a/run/Main.hs +++ b/run/Main.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)