OperationState.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | The state one operation owns while it works: the legalization arena, the
-- shared scratch arena, and the instrumentation cells. None of it is
-- topology, so none of it lives on @MutableDcel@ — a transaction allocates
-- this record when it thaws, hands it down to the operations it runs, and
-- reads the counters back once when it freezes. The hot loops thread their
-- stack top, maximum depth and flip count as strict loop variables and charge
-- these cells once per drain; cold events (one per insertion, one per walk
-- probe) charge them where they happen.
module Moonlight.Triangulation.Internal.OperationState
  ( Counter (..)
  , OperationState
  , newOperationState
  , legalizationArena
  , storeLegalizationArena
  , writeScratch
  , readScratch
  , addCounter
  , setCounter
  , maxCounter
  , readCounter
  , freezeBuildStats
  ) where

import Control.Monad (when)
import Control.Monad.ST (ST)
import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)
import qualified Data.Vector.Unboxed.Mutable as MUV
import Data.Word (Word32, Word64)
import Moonlight.Triangulation.Internal.Growable
  ( GrowableWord32
  , newGrowableWord32
  , readGrowable
  , writeGrowable
  )
import Moonlight.Triangulation.Internal.PackedIndex (packIndex)
import Moonlight.Triangulation.Internal.Types (BuildStats (..))

-- | Instrumentation cells. The first twenty constructors are exactly the
-- t'BuildStats' fields, in t'BuildStats' order; anything after
-- 'CounterRefinementQueuePops' is a diagnostic with no t'BuildStats' field and
-- is read only by instrumented entries, so 'freezeBuildStats' enumerates the
-- leading block and never sees the rest.
data Counter
  = CounterInputPoints
  | CounterUniquePoints
  | CounterExistingPoints
  | CounterDuplicatePoints
  | CounterSpatialSeedPoints
  | CounterFaceSplits
  | CounterInteriorEdgeSplits
  | CounterBoundaryEdgeSplits
  | CounterHullInsertions
  | CounterLineSplits
  | CounterLineExtensions
  | CounterLineToAreaTransitions
  | CounterEdgeFlips
  | CounterLocationWalkSteps
  | CounterLocationFallbacks
  | CounterLocationMaxWalk
  | CounterLegalizationMaxStack
  | CounterSteinerPoints
  | CounterRefinementFaceChecks
  | CounterRefinementQueuePops
  | CounterSweepFastPoints
  | CounterSweepSkippedPoints
  | CounterDiagLegalizationCandidates
  | CounterDiagHullBucketProbeSteps
  | CounterDiagHullKeyRebuilds
  | CounterCount
  deriving stock (Eq, Ord, Enum, Bounded, Show)

-- | One operation's working state. Scratch is fixed and raw: writes always
-- precede reads within an epoch. The legalization vector is held behind one
-- reference solely so an adversarial generic drain can grow it without
-- reintroducing mesh-global work state. A drain reads that reference once,
-- carries the vector and all stack metrics strictly, and stores it once when
-- finished; there is no per-candidate reference traffic.
data OperationState s = OperationState
  { osLegalizationArena :: !(STRef s (MUV.MVector s Word32))
  , osScratchArena :: !(GrowableWord32 s)
  , osCounters :: !(MUV.MVector s Word64)
  }

-- | Allocate transaction-sized working state. The legalization reservation is a
-- starting size, not a semantic limit: a generic flip pops one candidate and may
-- push four, no linear worst-case depth follows from the input size, and
-- overflow grows the operation-owned vector by doubling. So the reservation is
-- capped. A transaction-sized one charges every singleton verb a fresh block
-- group whose tail no drain reaches, and the doublings that reach a real peak
-- copy less in total than reserving that tail costs.
--
-- Scratch retains four disjoint half-edge sections as its semantic limit: the
-- removal kernel locally glues border, retired-edge, retired-face, and new-fan
-- sections there. Its physical storage still grows only with the star or strip
-- actually observed. Reserving the full mesh bound made every singleton
-- persistent edit allocate an arena whose untouched tail was orders of
-- magnitude larger than the edit.
newOperationState :: Int -> ST s (OperationState s)
newOperationState halfEdgeCapacity = do
  initialArena <- MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation)
  arena <- newSTRef initialArena
  scratch <- newGrowableWord32 (min 64 (halfEdgeCapacity + 8))
  counters <- MUV.replicate (fromEnum CounterCount) 0
  pure
    OperationState
      { osLegalizationArena = arena
      , osScratchArena = scratch
      , osCounters = counters
      }

-- | Ordinary cavities are tiny; exceptional stars and recovered strips grow
-- geometrically behind the sealed arena rather than taxing every singleton
-- edit for a pathological frontier it never visits.
initialLegalizationReservation :: Int
initialLegalizationReservation = 64

legalizationArena :: OperationState s -> ST s (MUV.MVector s Word32)
legalizationArena = readSTRef . osLegalizationArena
{-# INLINE legalizationArena #-}

storeLegalizationArena :: OperationState s -> MUV.MVector s Word32 -> ST s ()
storeLegalizationArena = writeSTRef . osLegalizationArena
{-# INLINE storeLegalizationArena #-}

-- | Write a scratch cell. Collection walks carry their topology-derived
-- termination budgets; the growable arena is physical storage, not a second
-- semantic bound capable of disagreeing with those typed obstructions.
writeScratch :: OperationState s -> Int -> Int -> ST s ()
writeScratch OperationState{osScratchArena} index value =
  writeGrowable osScratchArena index (packIndex value)
{-# INLINE writeScratch #-}

readScratch :: OperationState s -> Int -> ST s Int
readScratch OperationState{osScratchArena} index = fromIntegral <$> readGrowable osScratchArena index
{-# INLINE readScratch #-}

addCounter :: OperationState s -> Counter -> Int -> ST s ()
addCounter OperationState{osCounters} counter amount = do
  let !index = fromEnum counter
  current <- MUV.unsafeRead osCounters index
  MUV.unsafeWrite osCounters index (current + fromIntegral amount)
{-# INLINE addCounter #-}

setCounter :: OperationState s -> Counter -> Int -> ST s ()
setCounter OperationState{osCounters} counter value =
  MUV.unsafeWrite osCounters (fromEnum counter) (fromIntegral value)
{-# INLINE setCounter #-}

maxCounter :: OperationState s -> Counter -> Int -> ST s ()
maxCounter OperationState{osCounters} counter value = do
  let !index = fromEnum counter
  current <- MUV.unsafeRead osCounters index
  when (fromIntegral value > current) (MUV.unsafeWrite osCounters index (fromIntegral value))
{-# INLINE maxCounter #-}

readCounter :: OperationState s -> Counter -> ST s Int
readCounter OperationState{osCounters} counter =
  fromIntegral <$> MUV.unsafeRead osCounters (fromEnum counter)
{-# INLINE readCounter #-}

-- | Materialize the public statistics once, at freeze time, from the cells the
-- operation's subsystems charged while it ran. Diagnostic cells past
-- 'CounterRefinementQueuePops' have no t'BuildStats' field and are not read
-- here.
freezeBuildStats :: OperationState s -> ST s BuildStats
freezeBuildStats operation =
  BuildStats
    <$> readCounter operation CounterInputPoints
    <*> readCounter operation CounterUniquePoints
    <*> readCounter operation CounterExistingPoints
    <*> readCounter operation CounterDuplicatePoints
    <*> readCounter operation CounterSpatialSeedPoints
    <*> readCounter operation CounterFaceSplits
    <*> readCounter operation CounterInteriorEdgeSplits
    <*> readCounter operation CounterBoundaryEdgeSplits
    <*> readCounter operation CounterHullInsertions
    <*> readCounter operation CounterLineSplits
    <*> readCounter operation CounterLineExtensions
    <*> readCounter operation CounterLineToAreaTransitions
    <*> readCounter operation CounterEdgeFlips
    <*> readCounter operation CounterLocationWalkSteps
    <*> readCounter operation CounterLocationFallbacks
    <*> readCounter operation CounterLocationMaxWalk
    <*> readCounter operation CounterLegalizationMaxStack
    <*> readCounter operation CounterSteinerPoints
    <*> readCounter operation CounterRefinementFaceChecks
    <*> readCounter operation CounterRefinementQueuePops
    <*> readCounter operation CounterSweepFastPoints
    <*> readCounter operation CounterSweepSkippedPoints
{-# INLINE freezeBuildStats #-}