-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The composition root's memory plan: one solver that partitions the effective
heap ceiling between __named tenants__ whose sum is bounded by the ceiling, so the
budgets compose instead of each claiming an independent share of the same bytes.

With an effective ceiling @H@ ("Ecluse.Rts", what the RTS actually runs with), the
tenants are, in allocation order:

1. __The runtime reserve__: GC copying headroom, stacks, buffers, and the RTS
   itself, taken off the top; everything else partitions the remainder (the
   application heap).
2. __Fixed buffers__: the mirror enqueue hand-off buffer, charged whenever any
   mount mirrors (whatever the backend).
3. __The cache aggregate__: ONE byte budget for all three metadata stores, split
   into their named sub-budgets at 'planCacheConfig' (the split sums to the
   aggregate, so the cache can never triple its tenant).
4. __The material aggregate__: response materialisation working space. The
   admission capacity is @max 1 (min A_cpu A_mem)@ -- the CPU-derived capacity
   ("Ecluse.Composition.Sizing") jointly bounded by what the material share can
   actually hold, one envelope ('packumentOriginFanout' concurrent origins, each
   wire+parsed at 'expandWireBytes') per admitted operation.
5. __The publish aggregate__: the total bytes concurrently buffered publish
   bodies may hold (the byte-admission the publish pipeline acquires before
   reading a body), present only when a publication target is configured.
6. __The queue tenant__: the in-memory mirror queue's depth, charged only when
   the memory backend was selected (the selection precedes this plan; an SQS
   deployment spends no heap on queued jobs).
7. __The mirror-artifact tenant__: the transient publish envelope one back-fill
   job holds, charged whenever any mount mirrors (the same predicate as the fixed
   buffer). The worker buffers a fetched tarball whole and base64-encodes it into a
   strict publish document, so the tarball bytes, the base64 'Text', and the
   serialised document coexist before GC at roughly 'mirrorArtifactEnvelopeMultiplier'
   times the tarball; the worker's per-artifact byte cap ('matMaxBytes') is this
   share divided back down by that multiplier, so the envelope the cap admits is what
   the tenant charges (issue #846).

The combined invariant -- reserve + cache + material + publish + queue + fixed
buffers + mirror-artifact within the ceiling -- is enforced by construction for
computed shares. Explicit overrides are re-checked by attribution, described under
degradation below: a pin refuses the boot only when it is what a fitting plan cannot
shed around, never on mere presence.

== Graceful degradation, never a refusal

A pod too small for the tenants' normal floors sheds in a documented priority
order, each step a loud boot warning naming what was given up and why: first the
mirror-artifact cap shrinks, ultimately to zero (the background back-fill leg gives
way before the serve hot path, so a starved pod protects its cache and admission and
mirrors nothing it cannot buffer safely); then the cache aggregate shrinks below its
floor, ultimately to zero (the proxy serves uncached); then admission shrinks toward
one in-flight operation (and, where the nursery is the real pressure, the capability
count sheds with it, automating the smaller-cores recommendation); then the publish
aggregate shrinks to one maximum request; then the queue depth to its floor. One
operation on one capability with no cache is the irreducible minimum and __always
boots__ -- if even that exceeds the ceiling, the plan says so in its loudest warning
and boots anyway (the cgroup backstop is then the guard).

Only an __explicit operator override__ refuses the boot, and only when it is the
cause. The plan re-derives the override-free minimum (every pin substituted out,
every computed tenant at its floor) and refuses just when that minimum fits the
ceiling while the pinned plan does not, naming the pins whose individual removal
would fit (all of them when only their combination overshoots). A pin at or below
the value the shed ladder would compute anyway pushes the plan past nothing and
never refuses; a pod too small even without the pins boots with the loud warning
like any other. An override is an operator claim, and a claim that alone breaks
the ceiling is a misconfiguration to fix, not to shrink around.

With no ceiling datapoint at all, every bound falls back to the shipped values
that predate the plan. An explicit config value always wins its own bound, and
every decision returns a provenance line for the boot log.
-}
module Ecluse.Composition.MemoryPlan (
    MemoryPlan (..),
    PublishTenant (..),
    MirrorArtifactTenant (..),
    QueueTenantDemand (..),
    queueTenantDemand,
    resolveMemoryPlan,
    OverridePins,
    overrideMinShedSum,
    overrideSubstitutions,
    attributeOverrideViolations,
    planCacheConfig,
    mirrorArtifactEnvelopeMultiplier,
    mirrorArtifactBytesCap,
) where

import Data.Text qualified as T

import Ecluse.Composition.MirrorQueue (MirrorQueuePlan (MemoryBackend, SqsBackend), MirrorRuntimePlan (MirrorWith, NoMirroring))
import Ecluse.Composition.Sizing (mirrorEnqueueBufferDepth, resolveServeAdmission)
import Ecluse.Config (CacheSettings (..), LimitsSettings (..), QueueSettings (..))
import Ecluse.Core.Server.Cache (CacheConfig (..), StoreBudget (..))
import Ecluse.Core.Server.MemoryModel (contractResidentBytes, expandWireBytes, mirrorJobEstimatedBytes, packumentOriginFanout)
import Ecluse.Rts (EffectiveRuntimePlan (erpAllocAreaBytes), effectiveCapabilities, effectiveHeapCeiling, provenanceClause)

{- | Whether the memory plan owes the in-memory queue a tenant, projected from the
already-made backend selection ('Ecluse.Composition.MirrorQueue.planMirrorRuntime'):
only the memory backend spends heap on queued jobs, while any mirroring at all
charges the fixed enqueue buffer.
-}
data QueueTenantDemand
    = -- | No mount mirrors: no queue tenant, no enqueue buffer.
      NoQueueTenant
    | -- | Mirroring rides a durable backend: the enqueue buffer alone is charged.
      MirroringWithoutMemoryQueue
    | -- | Mirroring rides the in-memory queue: its depth is a tenant of this plan.
      MemoryQueueTenant
    deriving stock (QueueTenantDemand -> QueueTenantDemand -> Bool
(QueueTenantDemand -> QueueTenantDemand -> Bool)
-> (QueueTenantDemand -> QueueTenantDemand -> Bool)
-> Eq QueueTenantDemand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueueTenantDemand -> QueueTenantDemand -> Bool
== :: QueueTenantDemand -> QueueTenantDemand -> Bool
$c/= :: QueueTenantDemand -> QueueTenantDemand -> Bool
/= :: QueueTenantDemand -> QueueTenantDemand -> Bool
Eq, Int -> QueueTenantDemand -> ShowS
[QueueTenantDemand] -> ShowS
QueueTenantDemand -> String
(Int -> QueueTenantDemand -> ShowS)
-> (QueueTenantDemand -> String)
-> ([QueueTenantDemand] -> ShowS)
-> Show QueueTenantDemand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueueTenantDemand -> ShowS
showsPrec :: Int -> QueueTenantDemand -> ShowS
$cshow :: QueueTenantDemand -> String
show :: QueueTenantDemand -> String
$cshowList :: [QueueTenantDemand] -> ShowS
showList :: [QueueTenantDemand] -> ShowS
Show)

-- | Project the queue-tenant demand from the resolved mirror runtime plan.
queueTenantDemand :: MirrorRuntimePlan -> QueueTenantDemand
queueTenantDemand :: MirrorRuntimePlan -> QueueTenantDemand
queueTenantDemand = \case
    MirrorRuntimePlan
NoMirroring -> QueueTenantDemand
NoQueueTenant
    MirrorWith (SqsBackend SqsConfig
_) -> QueueTenantDemand
MirroringWithoutMemoryQueue
    MirrorWith MirrorQueuePlan
MemoryBackend -> QueueTenantDemand
MemoryQueueTenant

-- | The publish tenant: the aggregate byte-admission for concurrently buffered bodies.
newtype PublishTenant = PublishTenant
    { PublishTenant -> Int
ptAggregateBytes :: Int
    }
    deriving stock (PublishTenant -> PublishTenant -> Bool
(PublishTenant -> PublishTenant -> Bool)
-> (PublishTenant -> PublishTenant -> Bool) -> Eq PublishTenant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublishTenant -> PublishTenant -> Bool
== :: PublishTenant -> PublishTenant -> Bool
$c/= :: PublishTenant -> PublishTenant -> Bool
/= :: PublishTenant -> PublishTenant -> Bool
Eq, Int -> PublishTenant -> ShowS
[PublishTenant] -> ShowS
PublishTenant -> String
(Int -> PublishTenant -> ShowS)
-> (PublishTenant -> String)
-> ([PublishTenant] -> ShowS)
-> Show PublishTenant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublishTenant -> ShowS
showsPrec :: Int -> PublishTenant -> ShowS
$cshow :: PublishTenant -> String
show :: PublishTenant -> String
$cshowList :: [PublishTenant] -> ShowS
showList :: [PublishTenant] -> ShowS
Show)

{- | The mirror-artifact tenant: the mirror worker's per-artifact byte cap. Present
only when some mount mirrors.

'matMaxBytes' is the tarball byte cap the worker's bounded fetch enforces
('Ecluse.Core.Worker.Fetch.fetchArtifactBytes'). The heap the combined invariant
charges for it is that cap scaled by 'mirrorArtifactEnvelopeMultiplier' -- what the
buffered tarball, its base64 'Text', and the serialised publish document may
transiently hold together.
-}
newtype MirrorArtifactTenant = MirrorArtifactTenant
    { MirrorArtifactTenant -> Int
matMaxBytes :: Int
    -- ^ The worker's per-artifact fetch byte cap (the tarball bound @B@).
    }
    deriving stock (MirrorArtifactTenant -> MirrorArtifactTenant -> Bool
(MirrorArtifactTenant -> MirrorArtifactTenant -> Bool)
-> (MirrorArtifactTenant -> MirrorArtifactTenant -> Bool)
-> Eq MirrorArtifactTenant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorArtifactTenant -> MirrorArtifactTenant -> Bool
== :: MirrorArtifactTenant -> MirrorArtifactTenant -> Bool
$c/= :: MirrorArtifactTenant -> MirrorArtifactTenant -> Bool
/= :: MirrorArtifactTenant -> MirrorArtifactTenant -> Bool
Eq, Int -> MirrorArtifactTenant -> ShowS
[MirrorArtifactTenant] -> ShowS
MirrorArtifactTenant -> String
(Int -> MirrorArtifactTenant -> ShowS)
-> (MirrorArtifactTenant -> String)
-> ([MirrorArtifactTenant] -> ShowS)
-> Show MirrorArtifactTenant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorArtifactTenant -> ShowS
showsPrec :: Int -> MirrorArtifactTenant -> ShowS
$cshow :: MirrorArtifactTenant -> String
show :: MirrorArtifactTenant -> String
$cshowList :: [MirrorArtifactTenant] -> ShowS
showList :: [MirrorArtifactTenant] -> ShowS
Show)

{- | The resolved plan: every byte-valued bound the composition root builds with,
each an explicit config value or its tenant-derived default, plus the degradation
warnings the solver took and any explicit-override violations (the one refusal).
-}
data MemoryPlan = MemoryPlan
    { MemoryPlan -> Int
mpRuntimeReserveBytes :: Int
    -- ^ Tenant 1: taken off the top; zero with no ceiling datapoint.
    , MemoryPlan -> Int
mpCacheAggregateBytes :: Int
    -- ^ Tenant 3: the one cache aggregate, split at 'planCacheConfig'.
    , MemoryPlan -> Int
mpCacheMaxEntries :: Int
    , MemoryPlan -> Int
mpMaterialAggregateBytes :: Int
    -- ^ Tenant 4: the materialisation envelope bytes admission may hold at once.
    , MemoryPlan -> Int
mpMaxResponseBytes :: Int
    -- ^ The per-response wire cap @R@ carved from the material aggregate.
    , MemoryPlan -> Int
mpMaxRequestBytes :: Int
    -- ^ The per-request (publish body) wire cap @Q@, enforced at the publish read site.
    , MemoryPlan -> Int
mpAdmissionCapacity :: Int
    -- ^ @max 1 (min A_cpu A_mem)@; the composition root builds admission from it.
    , MemoryPlan -> Maybe Int
mpShedCapabilities :: Maybe Int
    {- ^ A capability count to shrink to when the nursery is the memory pressure
    (each capability holds an allocation area); 'Nothing' when the live count
    stands. Applied in-process by the composition root.
    -}
    , MemoryPlan -> Maybe PublishTenant
mpPublishTenant :: Maybe PublishTenant
    -- ^ Tenant 5, present only when a publication target is configured.
    , MemoryPlan -> Maybe MirrorArtifactTenant
mpMirrorArtifactTenant :: Maybe MirrorArtifactTenant
    -- ^ Tenant 7, present only when some mount mirrors; carries the worker's cap.
    , MemoryPlan -> Int
mpQueueMemoryMaxDepth :: Int
    -- ^ The in-memory queue's depth cap (the build parameter, always resolved).
    , MemoryPlan -> Int
mpQueueTenantBytes :: Int
    -- ^ Tenant 6: the bytes the depth charges; zero unless the memory backend runs.
    , MemoryPlan -> Int
mpFixedBufferBytes :: Int
    -- ^ Tenant 2: the enqueue buffer, charged whenever any mount mirrors.
    , MemoryPlan -> [Text]
mpDegradations :: [Text]
    -- ^ The shed-ladder warnings, in the order taken; empty when everything fits.
    , MemoryPlan -> [Text]
mpOverrideViolations :: [Text]
    {- ^ The pins named as the cause of a residual overshoot the plan cannot shed
    around: populated only when the override-free minimum fits the ceiling while
    the pinned plan does not. The boot and check-config refuse on these (exit 2).
    A pin that contributes nothing to the overshoot is never named, and a pod too
    small even without the pins boots (a degradation, not a refusal).
    -}
    }
    deriving stock (MemoryPlan -> MemoryPlan -> Bool
(MemoryPlan -> MemoryPlan -> Bool)
-> (MemoryPlan -> MemoryPlan -> Bool) -> Eq MemoryPlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemoryPlan -> MemoryPlan -> Bool
== :: MemoryPlan -> MemoryPlan -> Bool
$c/= :: MemoryPlan -> MemoryPlan -> Bool
/= :: MemoryPlan -> MemoryPlan -> Bool
Eq, Int -> MemoryPlan -> ShowS
[MemoryPlan] -> ShowS
MemoryPlan -> String
(Int -> MemoryPlan -> ShowS)
-> (MemoryPlan -> String)
-> ([MemoryPlan] -> ShowS)
-> Show MemoryPlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MemoryPlan -> ShowS
showsPrec :: Int -> MemoryPlan -> ShowS
$cshow :: MemoryPlan -> String
show :: MemoryPlan -> String
$cshowList :: [MemoryPlan] -> ShowS
showList :: [MemoryPlan] -> ShowS
Show)

{- | Resolve the memory plan and its boot lines from the configuration groups, the
effective runtime plan, the explicit admission override, the queue-tenant demand
(the backend selection precedes this plan), and whether any mount publishes.
-}
resolveMemoryPlan ::
    CacheSettings ->
    LimitsSettings ->
    QueueSettings ->
    Maybe Int ->
    EffectiveRuntimePlan ->
    QueueTenantDemand ->
    Bool ->
    (MemoryPlan, [Text])
resolveMemoryPlan :: CacheSettings
-> LimitsSettings
-> QueueSettings
-> Maybe Int
-> EffectiveRuntimePlan
-> QueueTenantDemand
-> Bool
-> (MemoryPlan, [Text])
resolveMemoryPlan CacheSettings
cacheSettings LimitsSettings
limitsSettings QueueSettings
queueSettings Maybe Int
explicitAdmission EffectiveRuntimePlan
runtime QueueTenantDemand
queueDemand Bool
publishConfigured =
    (MemoryPlan, [Text])
-> (Int -> (MemoryPlan, [Text]))
-> Maybe Int
-> (MemoryPlan, [Text])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (CacheSettings
-> LimitsSettings
-> QueueSettings
-> Int
-> Text
-> QueueTenantDemand
-> Bool
-> Int
-> (MemoryPlan, [Text])
fallbackPlan CacheSettings
cacheSettings LimitsSettings
limitsSettings QueueSettings
queueSettings Int
cpuAdmission Text
cpuAdmissionLine QueueTenantDemand
queueDemand Bool
publishConfigured Int
fixedBuffers)
        Int -> (MemoryPlan, [Text])
solvedPlan
        Maybe Int
heapCeiling
  where
    (Maybe Int
heapCeiling, Provenance
ceilingProvenance) = EffectiveRuntimePlan -> (Maybe Int, Provenance)
effectiveHeapCeiling EffectiveRuntimePlan
runtime
    (Int
capabilities, Provenance
_) = EffectiveRuntimePlan -> (Int, Provenance)
effectiveCapabilities EffectiveRuntimePlan
runtime

    -- The CPU-derived admission capacity (explicit serveMaxInFlight wins inside).
    (Int
cpuAdmission, Text
cpuAdmissionLine) = Maybe Int -> Int -> (Int, Text)
resolveServeAdmission Maybe Int
explicitAdmission Int
capabilities

    fixedBuffers :: Int
fixedBuffers = case QueueTenantDemand
queueDemand of
        QueueTenantDemand
NoQueueTenant -> Int
0
        QueueTenantDemand
_ -> Int
mirrorEnqueueBufferDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorJobEstimatedBytes

    memoryBacked :: Bool
memoryBacked = QueueTenantDemand
queueDemand QueueTenantDemand -> QueueTenantDemand -> Bool
forall a. Eq a => a -> a -> Bool
== QueueTenantDemand
MemoryQueueTenant
    -- Any mirroring at all (whatever the backend) charges the mirror-artifact tenant,
    -- the same predicate the fixed enqueue buffer rides.
    mirrors :: Bool
mirrors = QueueTenantDemand
queueDemand QueueTenantDemand -> QueueTenantDemand -> Bool
forall a. Eq a => a -> a -> Bool
/= QueueTenantDemand
NoQueueTenant

    {- The solved plan over a ceiling h: resolve each tenant's desired share, shed to
    fit ('shedToFit'), then render the boot log from the outcomes. The arithmetic (the
    demands, the ladder) is kept apart from the prose so the sum-within-ceiling
    invariant reads without stepping through boot-log text. -}
    solvedPlan :: Int -> (MemoryPlan, [Text])
    solvedPlan :: Int -> (MemoryPlan, [Text])
solvedPlan Int
h =
        ( MemoryPlan
            { mpRuntimeReserveBytes :: Int
mpRuntimeReserveBytes = Int
reserve
            , mpCacheAggregateBytes :: Int
mpCacheAggregateBytes = ShedOutcomes -> Int
soCacheFinal ShedOutcomes
outcomes
            , mpCacheMaxEntries :: Int
mpCacheMaxEntries = Int
cacheEntries
            , mpMaterialAggregateBytes :: Int
mpMaterialAggregateBytes = ShedOutcomes -> Int
soMaterialFinal ShedOutcomes
outcomes
            , mpMaxResponseBytes :: Int
mpMaxResponseBytes = ShedOutcomes -> Int
soResponseFinal ShedOutcomes
outcomes
            , mpMaxRequestBytes :: Int
mpMaxRequestBytes = Int
requestFinal
            , mpAdmissionCapacity :: Int
mpAdmissionCapacity = ShedOutcomes -> Int
soAdmissionFinal ShedOutcomes
outcomes
            , mpShedCapabilities :: Maybe Int
mpShedCapabilities = Maybe Int
shedCaps
            , mpPublishTenant :: Maybe PublishTenant
mpPublishTenant = Maybe PublishTenant
publishTenant
            , mpMirrorArtifactTenant :: Maybe MirrorArtifactTenant
mpMirrorArtifactTenant = Maybe MirrorArtifactTenant
mirrorArtifactTenant
            , mpQueueMemoryMaxDepth :: Int
mpQueueMemoryMaxDepth = ShedOutcomes -> Int
soDepthFinal ShedOutcomes
outcomes
            , mpQueueTenantBytes :: Int
mpQueueTenantBytes = ShedOutcomes -> Int
soQueueTenantBytes ShedOutcomes
outcomes
            , mpFixedBufferBytes :: Int
mpFixedBufferBytes = Int
fixedBuffers
            , mpDegradations :: [Text]
mpDegradations = TenantDemands
-> ShedOutcomes -> Int -> Int -> Maybe Int -> Int -> [Text]
renderDegradations TenantDemands
demands ShedOutcomes
outcomes Int
capabilities Int
allocArea Maybe Int
shedCaps Int
overshootWithoutOverrides
            , mpOverrideViolations :: [Text]
mpOverrideViolations = [Text]
overrideViolations
            }
        , TenantDemands
-> ShedOutcomes
-> Text
-> Text
-> Int
-> Bool
-> Maybe PublishTenant
-> Maybe MirrorArtifactTenant
-> [Text]
renderPlanLines TenantDemands
demands ShedOutcomes
outcomes Text
ceilingClause Text
cpuAdmissionLine Int
cacheEntries (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (CacheSettings -> Maybe Int
csMaxEntries CacheSettings
cacheSettings)) Maybe PublishTenant
publishTenant Maybe MirrorArtifactTenant
mirrorArtifactTenant
        )
      where
        reserve :: Int
reserve = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
runtimeReserveFloorBytes (Int
h Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
runtimeReserveShareDiv)
        appHeap :: Int
appHeap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
reserve)

        -- Each shedable tenant's desired share, remembering which were pinned by an
        -- explicit config value (an explicit bound never sheds; a violation attributes
        -- to it).
        cacheExplicit :: Maybe Int
cacheExplicit = CacheSettings -> Maybe Int
csMaxBytes CacheSettings
cacheSettings
        cacheDesired :: Int
cacheDesired = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
cacheBytesFloor Int
cacheBytesCap (Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cacheSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)) Maybe Int
cacheExplicit

        requestExplicit :: Maybe Int
requestExplicit = LimitsSettings -> Maybe Int
limMaxRequestBytes LimitsSettings
limitsSettings
        computedRequestDefault :: Int
computedRequestDefault = Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
requestBytesFloor Int
requestBytesCap (Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
publishSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)
        requestFinal :: Int
requestFinal = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
computedRequestDefault Maybe Int
requestExplicit
        publishDesired :: Int
publishDesired = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
requestFinal (Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
publishSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)

        responseExplicit :: Maybe Int
responseExplicit = LimitsSettings -> Maybe Int
limMaxResponseBytes LimitsSettings
limitsSettings
        materialShareBytes :: Int
materialShareBytes = Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
materialSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100

        -- Admission bounded jointly: the CPU capacity and what the material share
        -- holds at the floor response cap. An explicit serveMaxInFlight is a pinned
        -- claim (cpuAdmission already carries it).
        admissionMemBound :: Int
admissionMemBound = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
materialShareBytes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int
envelope Int
responseBytesFloor)
        admissionDesired :: Int
admissionDesired = case Maybe Int
explicitAdmission of
            Just Int
n -> Int
n
            Maybe Int
Nothing -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
cpuAdmission Int
admissionMemBound)

        -- The response cap the material share affords at the desired admission, by the
        -- shared wire-to-resident ratio ('contractResidentBytes' inverts the envelope).
        responseDesired :: Int
responseDesired =
            Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
                (Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
responseBytesFloor Int
responseBytesCap (Int -> Int
contractResidentBytes (Int
materialShareBytes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
admissionDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
packumentOriginFanout))))
                Maybe Int
responseExplicit
        materialDesired :: Int
materialDesired = Int -> Int -> Int
materialOf Int
admissionDesired Int
responseDesired
        materialMinimum :: Int
materialMinimum = Int -> Int -> Int
materialOf (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
explicitAdmission) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
responseBytesFloor Maybe Int
responseExplicit)

        depthExplicit :: Maybe Int
depthExplicit = QueueSettings -> Maybe Int
qsMemoryMaxDepth QueueSettings
queueSettings
        depthDesired :: Int
depthDesired = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
queueDepthFloor Int
queueDepthCap ((Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
queueSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
mirrorJobEstimatedBytes)) Maybe Int
depthExplicit

        -- The mirror-artifact cap: an explicit config value, else the mirror-artifact
        -- share divided by the envelope multiplier and capped, so the charged envelope
        -- (cap x multiplier) is a bounded share of the heap. Charged only when mirroring.
        artifactExplicit :: Maybe Int
artifactExplicit = LimitsSettings -> Maybe Int
limMaxArtifactBytes LimitsSettings
limitsSettings
        artifactCapDesired :: Int
artifactCapDesired =
            Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
                (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
mirrorArtifactBytesCap ((Int
appHeap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorArtifactSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
mirrorArtifactEnvelopeMultiplier))
                Maybe Int
artifactExplicit
        mirrorChargeDesired :: Int
mirrorChargeDesired = if Bool
mirrors then Int
artifactCapDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorArtifactEnvelopeMultiplier else Int
0

        demands :: TenantDemands
demands =
            TenantDemands
                { tdCeiling :: Int
tdCeiling = Int
h
                , tdReserve :: Int
tdReserve = Int
reserve
                , tdFixedBuffers :: Int
tdFixedBuffers = Int
fixedBuffers
                , tdCacheDesired :: Int
tdCacheDesired = Int
cacheDesired
                , tdCacheExplicit :: Maybe Int
tdCacheExplicit = Maybe Int
cacheExplicit
                , tdMaterialDesired :: Int
tdMaterialDesired = Int
materialDesired
                , tdMaterialMinimum :: Int
tdMaterialMinimum = Int
materialMinimum
                , tdAdmissionDesired :: Int
tdAdmissionDesired = Int
admissionDesired
                , tdAdmissionExplicit :: Maybe Int
tdAdmissionExplicit = Maybe Int
explicitAdmission
                , tdResponseExplicit :: Maybe Int
tdResponseExplicit = Maybe Int
responseExplicit
                , tdPublishConfigured :: Bool
tdPublishConfigured = Bool
publishConfigured
                , tdPublishDesired :: Int
tdPublishDesired = Int
publishDesired
                , tdRequestFinal :: Int
tdRequestFinal = Int
requestFinal
                , tdRequestExplicit :: Maybe Int
tdRequestExplicit = Maybe Int
requestExplicit
                , tdDepthDesired :: Int
tdDepthDesired = Int
depthDesired
                , tdDepthExplicit :: Maybe Int
tdDepthExplicit = Maybe Int
depthExplicit
                , tdMemoryBacked :: Bool
tdMemoryBacked = Bool
memoryBacked
                , tdMirrors :: Bool
tdMirrors = Bool
mirrors
                , tdArtifactCapDesired :: Int
tdArtifactCapDesired = Int
artifactCapDesired
                , tdMirrorChargeDesired :: Int
tdMirrorChargeDesired = Int
mirrorChargeDesired
                , tdArtifactExplicit :: Maybe Int
tdArtifactExplicit = Maybe Int
artifactExplicit
                }
        outcomes :: ShedOutcomes
outcomes = TenantDemands -> ShedOutcomes
shedToFit TenantDemands
demands

        -- The nursery (capabilities x allocation area) lives outside the heap ceiling,
        -- so the tenant sum cannot see it; the capability count sheds on its own.
        allocArea :: Int
allocArea = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (EffectiveRuntimePlan -> Int
erpAllocAreaBytes EffectiveRuntimePlan
runtime)
        shedCaps :: Maybe Int
shedCaps = Int -> Int -> Int -> Maybe Int
shedCapabilityCount Int
h Int
capabilities Int
allocArea

        publishTenant :: Maybe PublishTenant
publishTenant = [PublishTenant] -> Maybe PublishTenant
forall a. [a] -> Maybe a
listToMaybe [PublishTenant{ptAggregateBytes :: Int
ptAggregateBytes = ShedOutcomes -> Int
soPublishFinal ShedOutcomes
outcomes} | Bool
publishConfigured]
        mirrorArtifactTenant :: Maybe MirrorArtifactTenant
mirrorArtifactTenant =
            [MirrorArtifactTenant] -> Maybe MirrorArtifactTenant
forall a. [a] -> Maybe a
listToMaybe [MirrorArtifactTenant{matMaxBytes :: Int
matMaxBytes = ShedOutcomes -> Int
soArtifactCapFinal ShedOutcomes
outcomes} | Bool
mirrors]
        cacheEntries :: Int
cacheEntries = case CacheSettings -> Maybe Int
csMaxEntries CacheSettings
cacheSettings of
            Just Int
n -> Int
n
            Maybe Int
Nothing -> Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
cacheEntriesFloor Int
cacheEntriesCap (ShedOutcomes -> Int
soCacheFinal ShedOutcomes
outcomes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cacheEntryExpectedBytes)

        ceilingClause :: Text
ceilingClause = Provenance -> Text
provenanceClause Provenance
ceilingProvenance

        -- Attribute a residual overshoot to the pins that cause it before refusing:
        -- substitute the pins out (all at once for the override-free minimum, then one
        -- at a time) and let 'attributeOverrideViolations' name the culprits.
        actualPins :: (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
actualPins = (Maybe Int
cacheExplicit, Maybe Int
explicitAdmission, Maybe Int
responseExplicit, Maybe Int
requestExplicit, Maybe Int
depthExplicit, Maybe Int
artifactExplicit)
        overshootFor :: (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
-> Int
overshootFor (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
pins =
            Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
-> Int
-> Bool
-> Bool
-> Bool
-> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
    Maybe Int)
-> Int
overrideMinShedSum (Int
reserve Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fixedBuffers) Int
computedRequestDefault Bool
publishConfigured Bool
memoryBacked Bool
mirrors (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
pins Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
h)
        overshootWithoutOverrides :: Int
overshootWithoutOverrides = (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
-> Int
overshootFor (Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
forall a. Maybe a
Nothing)
        overrideViolations :: [Text]
overrideViolations =
            Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations
                Int
h
                (ShedOutcomes -> Int
soResidualOvershoot ShedOutcomes
outcomes)
                Int
overshootWithoutOverrides
                [(Text
name, (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
-> Int
overshootFor (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
pins) | (Text
name, (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
pins) <- (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
-> [(Text,
     (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
      Maybe Int))]
overrideSubstitutions (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
actualPins]

-- One admitted operation's envelope at response cap r: the concurrent origins'
-- wire+parsed forms, by the shared wire-to-resident model.
envelope :: Int -> Int
envelope :: Int -> Int
envelope Int
r = Int
packumentOriginFanout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
expandWireBytes Int
r

materialOf :: Int -> Int -> Int
materialOf :: Int -> Int -> Int
materialOf Int
a Int
r = Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
envelope Int
r

-- The bytes a memory-queue depth charges; nil unless the memory backend runs.
queueCharge :: Bool -> Int -> Int
queueCharge :: Bool -> Int -> Int
queueCharge Bool
memoryBacked Int
d = if Bool
memoryBacked then Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorJobEstimatedBytes else Int
0

clamp :: (Ord a) => a -> a -> a -> a
clamp :: forall a. Ord a => a -> a -> a -> a
clamp a
lo a
hi = a -> a -> a
forall a. Ord a => a -> a -> a
max a
lo (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Ord a => a -> a -> a
min a
hi

{- No ceiling datapoint: the shipped fallbacks that predate the plan, admission from
CPU alone, and no tenant arithmetic to check (there is nothing to sum against). -}
fallbackPlan ::
    CacheSettings ->
    LimitsSettings ->
    QueueSettings ->
    Int ->
    Text ->
    QueueTenantDemand ->
    Bool ->
    Int ->
    (MemoryPlan, [Text])
fallbackPlan :: CacheSettings
-> LimitsSettings
-> QueueSettings
-> Int
-> Text
-> QueueTenantDemand
-> Bool
-> Int
-> (MemoryPlan, [Text])
fallbackPlan CacheSettings
cacheSettings LimitsSettings
limitsSettings QueueSettings
queueSettings Int
cpuAdmission Text
cpuAdmissionLine QueueTenantDemand
queueDemand Bool
publishConfigured Int
fixedBuffers =
    ( MemoryPlan
        { mpRuntimeReserveBytes :: Int
mpRuntimeReserveBytes = Int
0
        , mpCacheAggregateBytes :: Int
mpCacheAggregateBytes = Int
cacheBytes
        , mpCacheMaxEntries :: Int
mpCacheMaxEntries = Int
cacheEntries
        , mpMaterialAggregateBytes :: Int
mpMaterialAggregateBytes = Int
0
        , mpMaxResponseBytes :: Int
mpMaxResponseBytes = Int
responseBytes
        , mpMaxRequestBytes :: Int
mpMaxRequestBytes = Int
requestBytes
        , mpAdmissionCapacity :: Int
mpAdmissionCapacity = Int
cpuAdmission
        , mpShedCapabilities :: Maybe Int
mpShedCapabilities = Maybe Int
forall a. Maybe a
Nothing
        , mpPublishTenant :: Maybe PublishTenant
mpPublishTenant = Maybe PublishTenant
publishTenant
        , mpMirrorArtifactTenant :: Maybe MirrorArtifactTenant
mpMirrorArtifactTenant = Maybe MirrorArtifactTenant
mirrorArtifactTenant
        , mpQueueMemoryMaxDepth :: Int
mpQueueMemoryMaxDepth = Int
queueDepth
        , mpQueueTenantBytes :: Int
mpQueueTenantBytes = Bool -> Int -> Int
queueCharge (QueueTenantDemand
queueDemand QueueTenantDemand -> QueueTenantDemand -> Bool
forall a. Eq a => a -> a -> Bool
== QueueTenantDemand
MemoryQueueTenant) Int
queueDepth
        , mpFixedBufferBytes :: Int
mpFixedBufferBytes = Int
fixedBuffers
        , mpDegradations :: [Text]
mpDegradations = []
        , mpOverrideViolations :: [Text]
mpOverrideViolations = []
        }
    , [Text
cpuAdmissionLine, Text
responseLine, Text
requestLine, Text
cacheBytesLine, Text
cacheEntriesLine, Text
queueDepthLine]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
artifactLine | Bool
mirrors]
    )
  where
    mirrors :: Bool
mirrors = QueueTenantDemand
queueDemand QueueTenantDemand -> QueueTenantDemand -> Bool
forall a. Eq a => a -> a -> Bool
/= QueueTenantDemand
NoQueueTenant
    (Int
responseBytes, Text
responseLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"response byte cap" (LimitsSettings -> Maybe Int
limMaxResponseBytes LimitsSettings
limitsSettings) Int
responseBytesFallback
    (Int
requestBytes, Text
requestLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"request byte cap" (LimitsSettings -> Maybe Int
limMaxRequestBytes LimitsSettings
limitsSettings) Int
requestBytesFallback
    (Int
cacheBytes, Text
cacheBytesLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"cache byte bound" (CacheSettings -> Maybe Int
csMaxBytes CacheSettings
cacheSettings) Int
cacheBytesFallback
    (Int
cacheEntries, Text
cacheEntriesLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"cache entry bound" (CacheSettings -> Maybe Int
csMaxEntries CacheSettings
cacheSettings) (Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
cacheEntriesFloor Int
cacheEntriesCap (Int
cacheBytes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cacheEntryExpectedBytes))
    (Int
queueDepth, Text
queueDepthLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"memory-queue depth" (QueueSettings -> Maybe Int
qsMemoryMaxDepth QueueSettings
queueSettings) Int
queueDepthFallback
    -- With no ceiling datapoint the artifact cap falls back to the shipped 512 MiB
    -- ceiling that predates the plan; a configured value always wins.
    (Int
artifactBytes, Text
artifactLine) = Text -> Maybe Int -> Int -> (Int, Text)
forall {b} {a}.
(Semigroup b, IsString b, Show a) =>
b -> Maybe a -> a -> (a, b)
fallbackOr Text
"mirror artifact byte cap" (LimitsSettings -> Maybe Int
limMaxArtifactBytes LimitsSettings
limitsSettings) Int
mirrorArtifactBytesCap
    publishTenant :: Maybe PublishTenant
publishTenant = [PublishTenant] -> Maybe PublishTenant
forall a. [a] -> Maybe a
listToMaybe [PublishTenant{ptAggregateBytes :: Int
ptAggregateBytes = Int
publishAggregateFallbackRequests Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
requestBytes} | Bool
publishConfigured]
    mirrorArtifactTenant :: Maybe MirrorArtifactTenant
mirrorArtifactTenant =
        [MirrorArtifactTenant] -> Maybe MirrorArtifactTenant
forall a. [a] -> Maybe a
listToMaybe [MirrorArtifactTenant{matMaxBytes :: Int
matMaxBytes = Int
artifactBytes} | Bool
mirrors]

    fallbackOr :: b -> Maybe a -> a -> (a, b)
fallbackOr b
name Maybe a
explicit a
fallback = case Maybe a
explicit of
        Just a
n -> (a
n, b
"memory plan: " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
name b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
" " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> a -> b
forall b a. (Show a, IsString b) => a -> b
show a
n b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
" (from config)")
        Maybe a
Nothing -> (a
fallback, b
"memory plan: " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
name b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
" " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> a -> b
forall b a. (Show a, IsString b) => a -> b
show a
fallback b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
" (built-in default; no heap-ceiling datapoint)")

-- The desired byte charges and reclaim floors the shed ladder walks, resolved from
-- the ceiling before any shedding. An explicit ('Just') bound never sheds.
data TenantDemands = TenantDemands
    { TenantDemands -> Int
tdCeiling :: Int
    , TenantDemands -> Int
tdReserve :: Int
    , TenantDemands -> Int
tdFixedBuffers :: Int
    , TenantDemands -> Int
tdCacheDesired :: Int
    , TenantDemands -> Maybe Int
tdCacheExplicit :: Maybe Int
    , TenantDemands -> Int
tdMaterialDesired :: Int
    , TenantDemands -> Int
tdMaterialMinimum :: Int
    , TenantDemands -> Int
tdAdmissionDesired :: Int
    , TenantDemands -> Maybe Int
tdAdmissionExplicit :: Maybe Int
    , TenantDemands -> Maybe Int
tdResponseExplicit :: Maybe Int
    , TenantDemands -> Bool
tdPublishConfigured :: Bool
    , TenantDemands -> Int
tdPublishDesired :: Int
    , TenantDemands -> Int
tdRequestFinal :: Int
    , TenantDemands -> Maybe Int
tdRequestExplicit :: Maybe Int
    , TenantDemands -> Int
tdDepthDesired :: Int
    , TenantDemands -> Maybe Int
tdDepthExplicit :: Maybe Int
    , TenantDemands -> Bool
tdMemoryBacked :: Bool
    , TenantDemands -> Bool
tdMirrors :: Bool
    , TenantDemands -> Int
tdArtifactCapDesired :: Int
    , TenantDemands -> Int
tdMirrorChargeDesired :: Int
    , TenantDemands -> Maybe Int
tdArtifactExplicit :: Maybe Int
    }

-- Every tenant's post-shed value plus the residual overshoot the ladder could not
-- reclaim. The combined invariant is a pure function of this record.
data ShedOutcomes = ShedOutcomes
    { ShedOutcomes -> Int
soMirrorShed :: Int
    , ShedOutcomes -> Int
soArtifactCapFinal :: Int
    , ShedOutcomes -> Int
soCacheShed :: Int
    , ShedOutcomes -> Int
soCacheFinal :: Int
    , ShedOutcomes -> Int
soMaterialShed :: Int
    , ShedOutcomes -> Int
soMaterialFinal :: Int
    , ShedOutcomes -> Int
soAdmissionFinal :: Int
    , ShedOutcomes -> Int
soResponseFinal :: Int
    , ShedOutcomes -> Int
soPublishShed :: Int
    , ShedOutcomes -> Int
soPublishFinal :: Int
    , ShedOutcomes -> Int
soQueueShedBytes :: Int
    , ShedOutcomes -> Int
soDepthFinal :: Int
    , ShedOutcomes -> Int
soQueueTenantBytes :: Int
    , ShedOutcomes -> Int
soResidualOvershoot :: Int
    }

-- One shed-ladder step: give up as much of a tenant's reclaimable bytes as the
-- residual overshoot demands. 'stepFinal' is the value after shedding, 'stepResidual'
-- the overshoot the next step inherits.
data ShedStep = ShedStep
    { ShedStep -> Int
stepShed :: Int
    , ShedStep -> Int
stepFinal :: Int
    , ShedStep -> Int
stepResidual :: Int
    }

shedStep :: Int -> Int -> Int -> ShedStep
shedStep :: Int -> Int -> Int -> ShedStep
shedStep Int
overshoot Int
desired Int
reclaimable =
    ShedStep{stepShed :: Int
stepShed = Int
shed, stepFinal :: Int
stepFinal = Int
desired Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
shed, stepResidual :: Int
stepResidual = Int
overshoot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
shed}
  where
    shed :: Int
shed = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
overshoot Int
reclaimable

-- Step 0: the mirror-artifact cap gives way first, to zero if needed (the background
-- back-fill leg is surrendered before the serve hot path). An explicit cap never sheds.
shedMirrorStep :: Int -> Int -> Maybe Int -> ShedStep
shedMirrorStep :: Int -> Int -> Maybe Int -> ShedStep
shedMirrorStep Int
overshoot Int
mirrorDesired Maybe Int
artifactExplicit =
    Int -> Int -> Int -> ShedStep
shedStep Int
overshoot Int
mirrorDesired (if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
artifactExplicit then Int
0 else Int
mirrorDesired)

-- Step 1: the cache gives way next, to zero if needed (never an explicit one).
shedCacheStep :: Int -> Int -> Maybe Int -> ShedStep
shedCacheStep :: Int -> Int -> Maybe Int -> ShedStep
shedCacheStep Int
overshoot Int
cacheDesired Maybe Int
cacheExplicit =
    Int -> Int -> Int -> ShedStep
shedStep Int
overshoot Int
cacheDesired (if Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
cacheExplicit then Int
0 else Int
cacheDesired)

-- The material tenant after shedding: the shed step plus the admission and response
-- caps the surviving share affords.
data MaterialOutcome = MaterialOutcome
    { MaterialOutcome -> ShedStep
moStep :: ShedStep
    , MaterialOutcome -> Int
moAdmission :: Int
    , MaterialOutcome -> Int
moResponse :: Int
    }

{- Step 2: admission shrinks toward one in-flight operation at the floor response cap
(never an explicit one); the surviving material share then fixes the admission and the
response cap, the latter by the shared wire-to-resident ratio. -}
shedMaterialStep :: Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> MaterialOutcome
shedMaterialStep :: Int
-> Int -> Int -> Int -> Maybe Int -> Maybe Int -> MaterialOutcome
shedMaterialStep Int
overshoot Int
materialDesired Int
materialMinimum Int
admissionDesired Maybe Int
explicitAdmission Maybe Int
responseExplicit =
    MaterialOutcome{moStep :: ShedStep
moStep = ShedStep
step, moAdmission :: Int
moAdmission = Int
admissionFinal, moResponse :: Int
moResponse = Int
responseFinal}
  where
    step :: ShedStep
step = Int -> Int -> Int -> ShedStep
shedStep Int
overshoot Int
materialDesired (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
materialDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
materialMinimum))
    materialFinal :: Int
materialFinal = ShedStep -> Int
stepFinal ShedStep
step
    admissionFinal :: Int
admissionFinal = case Maybe Int
explicitAdmission of
        Just Int
n -> Int
n
        Maybe Int
Nothing -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
admissionDesired (Int
materialFinal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int
envelope (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
responseBytesFloor Maybe Int
responseExplicit)))
    responseFinal :: Int
responseFinal = case Maybe Int
responseExplicit of
        Just Int
r -> Int
r
        Maybe Int
Nothing -> Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
responseBytesFloor Int
responseBytesCap (Int -> Int
contractResidentBytes (Int
materialFinal Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
admissionFinal Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
packumentOriginFanout)))

-- Step 3: the publish aggregate shrinks to one maximum request.
shedPublishStep :: Int -> Bool -> Int -> Int -> ShedStep
shedPublishStep :: Int -> Bool -> Int -> Int -> ShedStep
shedPublishStep Int
overshoot Bool
publishConfigured Int
publishDesired Int
requestFloor =
    Int -> Int -> Int -> ShedStep
shedStep Int
overshoot Int
publishDesired (if Bool
publishConfigured then Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
publishDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
requestFloor) else Int
0)

-- The queue tenant after shedding: bytes shed, the depth cap (in jobs), and the bytes
-- that depth charges.
data QueueOutcome = QueueOutcome
    { QueueOutcome -> Int
qoShed :: Int
    , QueueOutcome -> Int
qoDepthFinal :: Int
    , QueueOutcome -> Int
qoTenantBytes :: Int
    , QueueOutcome -> Int
qoResidual :: Int
    }

-- Step 4: the memory-queue depth to its floor (never an explicit one).
shedQueueStep :: Int -> Bool -> Int -> Maybe Int -> QueueOutcome
shedQueueStep :: Int -> Bool -> Int -> Maybe Int -> QueueOutcome
shedQueueStep Int
overshoot Bool
memoryBacked Int
depthDesired Maybe Int
depthExplicit =
    QueueOutcome
        { qoShed :: Int
qoShed = Int
queueShedBytes
        , qoDepthFinal :: Int
qoDepthFinal = Int
depthFinal
        , qoTenantBytes :: Int
qoTenantBytes = Int -> Int
charge Int
depthFinal
        , qoResidual :: Int
qoResidual = Int
overshoot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
queueShedBytes
        }
  where
    charge :: Int -> Int
charge = Bool -> Int -> Int
queueCharge Bool
memoryBacked
    depthReclaimableBytes :: Int
depthReclaimableBytes = case Maybe Int
depthExplicit of
        Just Int
_ -> Int
0
        Maybe Int
Nothing -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int
charge Int
depthDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
charge Int
queueDepthFloor)
    queueShedBytes :: Int
queueShedBytes = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
overshoot Int
depthReclaimableBytes
    depthFinal :: Int
depthFinal = case Maybe Int
depthExplicit of
        Just Int
n -> Int
n
        Maybe Int
Nothing
            | Int
queueShedBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
queueDepthFloor ((Int -> Int
charge Int
depthDesired Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
queueShedBytes) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
mirrorJobEstimatedBytes)
            | Bool
otherwise -> Int
depthDesired

{- Walk the shed ladder over the resolved demands: allocate every tenant at its desired
share, then shed in priority order (the mirror-artifact cap first, then cache, then
admission/material, then publish, then queue depth) until the sum fits or every computed
tenant is at its minimum. The residual overshoot is what even the fully-shed plan cannot
reclaim. -}
shedToFit :: TenantDemands -> ShedOutcomes
shedToFit :: TenantDemands -> ShedOutcomes
shedToFit TenantDemands
d =
    ShedOutcomes
        { soMirrorShed :: Int
soMirrorShed = ShedStep -> Int
stepShed ShedStep
mirrorStep
        , soArtifactCapFinal :: Int
soArtifactCapFinal = Int
artifactCapFinal
        , soCacheShed :: Int
soCacheShed = ShedStep -> Int
stepShed ShedStep
cacheStep
        , soCacheFinal :: Int
soCacheFinal = ShedStep -> Int
stepFinal ShedStep
cacheStep
        , soMaterialShed :: Int
soMaterialShed = ShedStep -> Int
stepShed ShedStep
materialStep
        , soMaterialFinal :: Int
soMaterialFinal = ShedStep -> Int
stepFinal ShedStep
materialStep
        , soAdmissionFinal :: Int
soAdmissionFinal = MaterialOutcome -> Int
moAdmission MaterialOutcome
material
        , soResponseFinal :: Int
soResponseFinal = MaterialOutcome -> Int
moResponse MaterialOutcome
material
        , soPublishShed :: Int
soPublishShed = ShedStep -> Int
stepShed ShedStep
publishStep
        , soPublishFinal :: Int
soPublishFinal = ShedStep -> Int
stepFinal ShedStep
publishStep
        , soQueueShedBytes :: Int
soQueueShedBytes = QueueOutcome -> Int
qoShed QueueOutcome
queue
        , soDepthFinal :: Int
soDepthFinal = QueueOutcome -> Int
qoDepthFinal QueueOutcome
queue
        , soQueueTenantBytes :: Int
soQueueTenantBytes = QueueOutcome -> Int
qoTenantBytes QueueOutcome
queue
        , soResidualOvershoot :: Int
soResidualOvershoot = QueueOutcome -> Int
qoResidual QueueOutcome
queue
        }
  where
    publishCharge :: Int
publishCharge = if TenantDemands -> Bool
tdPublishConfigured TenantDemands
d then TenantDemands -> Int
tdPublishDesired TenantDemands
d else Int
0
    desiredSum :: Int
desiredSum =
        TenantDemands -> Int
tdReserve TenantDemands
d
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TenantDemands -> Int
tdFixedBuffers TenantDemands
d
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TenantDemands -> Int
tdMirrorChargeDesired TenantDemands
d
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TenantDemands -> Int
tdCacheDesired TenantDemands
d
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TenantDemands -> Int
tdMaterialDesired TenantDemands
d
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
publishCharge
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int -> Int
queueCharge (TenantDemands -> Bool
tdMemoryBacked TenantDemands
d) (TenantDemands -> Int
tdDepthDesired TenantDemands
d)
    overshoot0 :: Int
overshoot0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
desiredSum Int -> Int -> Int
forall a. Num a => a -> a -> a
- TenantDemands -> Int
tdCeiling TenantDemands
d)

    mirrorStep :: ShedStep
mirrorStep = Int -> Int -> Maybe Int -> ShedStep
shedMirrorStep Int
overshoot0 (TenantDemands -> Int
tdMirrorChargeDesired TenantDemands
d) (TenantDemands -> Maybe Int
tdArtifactExplicit TenantDemands
d)
    -- The surviving cap after shedding: an explicit cap stands; a computed one is the
    -- shed charge divided back down by the envelope multiplier.
    artifactCapFinal :: Int
artifactCapFinal = case TenantDemands -> Maybe Int
tdArtifactExplicit TenantDemands
d of
        Just Int
n -> Int
n
        Maybe Int
Nothing -> ShedStep -> Int
stepFinal ShedStep
mirrorStep Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
mirrorArtifactEnvelopeMultiplier

    cacheStep :: ShedStep
cacheStep = Int -> Int -> Maybe Int -> ShedStep
shedCacheStep (ShedStep -> Int
stepResidual ShedStep
mirrorStep) (TenantDemands -> Int
tdCacheDesired TenantDemands
d) (TenantDemands -> Maybe Int
tdCacheExplicit TenantDemands
d)
    material :: MaterialOutcome
material =
        Int
-> Int -> Int -> Int -> Maybe Int -> Maybe Int -> MaterialOutcome
shedMaterialStep
            (ShedStep -> Int
stepResidual ShedStep
cacheStep)
            (TenantDemands -> Int
tdMaterialDesired TenantDemands
d)
            (TenantDemands -> Int
tdMaterialMinimum TenantDemands
d)
            (TenantDemands -> Int
tdAdmissionDesired TenantDemands
d)
            (TenantDemands -> Maybe Int
tdAdmissionExplicit TenantDemands
d)
            (TenantDemands -> Maybe Int
tdResponseExplicit TenantDemands
d)
    materialStep :: ShedStep
materialStep = MaterialOutcome -> ShedStep
moStep MaterialOutcome
material
    publishStep :: ShedStep
publishStep = Int -> Bool -> Int -> Int -> ShedStep
shedPublishStep (ShedStep -> Int
stepResidual ShedStep
materialStep) (TenantDemands -> Bool
tdPublishConfigured TenantDemands
d) (TenantDemands -> Int
tdPublishDesired TenantDemands
d) (TenantDemands -> Int
tdRequestFinal TenantDemands
d)
    queue :: QueueOutcome
queue = Int -> Bool -> Int -> Maybe Int -> QueueOutcome
shedQueueStep (ShedStep -> Int
stepResidual ShedStep
publishStep) (TenantDemands -> Bool
tdMemoryBacked TenantDemands
d) (TenantDemands -> Int
tdDepthDesired TenantDemands
d) (TenantDemands -> Maybe Int
tdDepthExplicit TenantDemands
d)

-- Where the nursery (capabilities x allocation area) exceeds a bounded share of the
-- ceiling, shed the capability count so it fits; 'Nothing' keeps the live count.
shedCapabilityCount :: Int -> Int -> Int -> Maybe Int
shedCapabilityCount :: Int -> Int -> Int -> Maybe Int
shedCapabilityCount Int
h Int
capabilities Int
allocArea
    | Int
capabilities Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
allocArea Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
h Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
nurseryCeilingShareDiv =
        let fitted :: Int
fitted = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ((Int
h Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
nurseryCeilingShareDiv) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
allocArea)
         in if Int
fitted Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
capabilities then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
fitted else Maybe Int
forall a. Maybe a
Nothing
    | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

-- The shed-ladder warnings, in ladder order, each naming what was given up and why: a
-- pure function of the outcomes and the nursery and irreducible-overshoot context.
renderDegradations :: TenantDemands -> ShedOutcomes -> Int -> Int -> Maybe Int -> Int -> [Text]
renderDegradations :: TenantDemands
-> ShedOutcomes -> Int -> Int -> Maybe Int -> Int -> [Text]
renderDegradations TenantDemands
d ShedOutcomes
o Int
capabilities Int
allocArea Maybe Int
shedCaps Int
overshootWithoutOverrides =
    [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
        [ [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [ Text
"memory plan: mirror artifact byte cap shed from "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (TenantDemands -> Int
tdArtifactCapDesired TenantDemands
d)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ShedOutcomes -> Int
soArtifactCapFinal ShedOutcomes
o)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes to fit the heap ceiling"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if ShedOutcomes -> Int
soArtifactCapFinal ShedOutcomes
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
" (this pod mirrors no artifact it cannot buffer safely)" else Text
"")
            | ShedOutcomes -> Int
soMirrorShed ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            ]
        , [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [ Text
"memory plan: cache aggregate shed from "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (TenantDemands -> Int
tdCacheDesired TenantDemands
d)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ShedOutcomes -> Int
soCacheFinal ShedOutcomes
o)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes to fit the heap ceiling"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if ShedOutcomes -> Int
soCacheFinal ShedOutcomes
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
" (the proxy serves uncached)" else Text
"")
            | ShedOutcomes -> Int
soCacheShed ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            ]
        , [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [ Text
"memory plan: admission shed to "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ShedOutcomes -> Int
soAdmissionFinal ShedOutcomes
o)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in-flight operation(s) (the material share cannot hold more at the floor response cap)"
            | ShedOutcomes -> Int
soMaterialShed ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            ]
        , ( \Int
c ->
                Text
"memory plan: capability count shed to "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
c
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (the nursery of "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
capabilities
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" capabilities x "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
allocArea
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes allocation area is the memory pressure; fewer, or a smaller GHCRTS -A, fits this pod)"
          )
            (Int -> Text) -> Maybe Int -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
shedCaps
        , [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [ Text
"memory plan: publish aggregate shed to one maximum request (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ShedOutcomes -> Int
soPublishFinal ShedOutcomes
o) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes)"
            | ShedOutcomes -> Int
soPublishShed ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            ]
        , [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [Text
"memory plan: memory-queue depth shed to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (ShedOutcomes -> Int
soDepthFinal ShedOutcomes
o) | ShedOutcomes -> Int
soQueueShedBytes ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]
        , [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
            [ Text
"memory plan: the irreducible minimum (one operation on one capability, no cache) still exceeds the heap ceiling by "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
overshootWithoutOverrides
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes; booting anyway with the container limit as the only backstop -- give this pod more memory"
            | ShedOutcomes -> Int
soResidualOvershoot ShedOutcomes
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
overshootWithoutOverrides Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            ]
        ]

-- The ordered boot lines check-config prints: one per resolved bound, tagged with its
-- provenance (an explicit config value, or the ceiling it was computed from).
renderPlanLines :: TenantDemands -> ShedOutcomes -> Text -> Text -> Int -> Bool -> Maybe PublishTenant -> Maybe MirrorArtifactTenant -> [Text]
renderPlanLines :: TenantDemands
-> ShedOutcomes
-> Text
-> Text
-> Int
-> Bool
-> Maybe PublishTenant
-> Maybe MirrorArtifactTenant
-> [Text]
renderPlanLines TenantDemands
d ShedOutcomes
o Text
ceilingClause Text
cpuAdmissionLine Int
cacheEntries Bool
entriesExplicit Maybe PublishTenant
publishTenant Maybe MirrorArtifactTenant
mirrorArtifactTenant =
    [ Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"runtime reserve" (TenantDemands -> Int
tdReserve TenantDemands
d) Bool
False
    , Text
cpuAdmissionLine
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"admission capacity" (ShedOutcomes -> Int
soAdmissionFinal ShedOutcomes
o) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdAdmissionExplicit TenantDemands
d))
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"material aggregate" (ShedOutcomes -> Int
soMaterialFinal ShedOutcomes
o) Bool
False
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"response byte cap" (ShedOutcomes -> Int
soResponseFinal ShedOutcomes
o) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdResponseExplicit TenantDemands
d))
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"request byte cap" (TenantDemands -> Int
tdRequestFinal TenantDemands
d) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdRequestExplicit TenantDemands
d))
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"cache byte bound" (ShedOutcomes -> Int
soCacheFinal ShedOutcomes
o) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdCacheExplicit TenantDemands
d))
    , Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"cache entry bound" Int
cacheEntries Bool
entriesExplicit
    ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"publish aggregate" (Int -> (PublishTenant -> Int) -> Maybe PublishTenant -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 PublishTenant -> Int
ptAggregateBytes Maybe PublishTenant
publishTenant) Bool
False | TenantDemands -> Bool
tdPublishConfigured TenantDemands
d]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"memory-queue depth" (ShedOutcomes -> Int
soDepthFinal ShedOutcomes
o) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdDepthExplicit TenantDemands
d)) | TenantDemands -> Bool
tdMemoryBacked TenantDemands
d]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Int -> Bool -> Text
forall {a}. Show a => Text -> a -> Bool -> Text
withCeiling Text
"mirror artifact byte cap" (Int
-> (MirrorArtifactTenant -> Int)
-> Maybe MirrorArtifactTenant
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 MirrorArtifactTenant -> Int
matMaxBytes Maybe MirrorArtifactTenant
mirrorArtifactTenant) (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (TenantDemands -> Maybe Int
tdArtifactExplicit TenantDemands
d)) | TenantDemands -> Bool
tdMirrors TenantDemands
d]
  where
    withCeiling :: Text -> a -> Bool -> Text
withCeiling Text
name a
value Bool
explicit =
        Text
"memory plan: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
value
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ( if Bool
explicit
                    then Text
" (from config)"
                    else Text
" (computed from heap ceiling " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (TenantDemands -> Int
tdCeiling TenantDemands
d) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ceilingClause Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
               )

{- | A hypothetical set of explicit overrides for the memory plan, in allocation
order: the cache byte bound, the serve admission, the response byte cap, the request
byte cap, the memory-queue depth, and the mirror-artifact byte cap, each pinned
('Just') or substituted out ('Nothing').
-}
type OverridePins = (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)

{- | The fully-shed minimum tenant sum for a hypothetical set of explicit pins: the
pin-independent @base@ (runtime reserve plus fixed buffers) plus each shedable tenant
at its pinned value, or un-pinned at the floor the shed ladder would reach -- cache
to zero, admission to one operation, response to its floor, the publish aggregate to
the computed one-request floor, the queue depth to its floor, and the mirror-artifact
envelope to zero (it sheds fully). @memoryBacked@ gates the queue tenant and @mirrors@
the mirror-artifact tenant: a durable or absent backend spends no heap on depth, and a
non-mirroring deployment none on the artifact envelope, whatever the pin's value.
Comparing this across pin sets attributes a residual overshoot to the pins that cause it.
-}
overrideMinShedSum :: Int -> Int -> Bool -> Bool -> Bool -> OverridePins -> Int
overrideMinShedSum :: Int
-> Int
-> Bool
-> Bool
-> Bool
-> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
    Maybe Int)
-> Int
overrideMinShedSum Int
base Int
computedRequestFloor Bool
publishPresent Bool
memoryBacked Bool
mirrors (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
pinArtifact) =
    Int
base
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
pinCache
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
materialFloor
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
publishPresent then Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
computedRequestFloor Maybe Int
pinRequest else Int
0)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
memoryBacked then Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
queueDepthFloor Maybe Int
pinDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorJobEstimatedBytes else Int
0)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
mirrors then Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorArtifactEnvelopeMultiplier) Maybe Int
pinArtifact else Int
0)
  where
    materialFloor :: Int
materialFloor = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
pinAdmission Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
packumentOriginFanout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
expandWireBytes (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
responseBytesFloor Maybe Int
pinResponse)

{- | Each explicit override present in the pin set, paired with the pin set that
substitutes only it out (the value the shed ladder would reach without it) and tagged
with the operator's config-key name, in the plan's allocation order. An absent
override contributes no substitution.
-}
overrideSubstitutions :: OverridePins -> [(Text, OverridePins)]
overrideSubstitutions :: (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int)
-> [(Text,
     (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
      Maybe Int))]
overrideSubstitutions (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
pinArtifact) =
    [Maybe
   (Text,
    (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
     Maybe Int))]
-> [(Text,
     (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int,
      Maybe Int))]
forall a. [Maybe a] -> [a]
catMaybes
        [ (Text
"cache.maxBytes", (Maybe Int
forall a. Maybe a
Nothing, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
pinArtifact)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinCache
        , (Text
"runtime.serveMaxInFlight", (Maybe Int
pinCache, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
pinArtifact)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinAdmission
        , (Text
"limits.maxResponseBytes", (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
pinArtifact)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinResponse
        , (Text
"limits.maxRequestBytes", (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
pinDepth, Maybe Int
pinArtifact)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinRequest
        , (Text
"queue.memoryMaxDepth", (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
forall a. Maybe a
Nothing, Maybe Int
pinArtifact)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinDepth
        , (Text
"limits.maxArtifactBytes", (Maybe Int
pinCache, Maybe Int
pinAdmission, Maybe Int
pinResponse, Maybe Int
pinRequest, Maybe Int
pinDepth, Maybe Int
forall a. Maybe a
Nothing)) (Text,
 (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
-> Maybe Int
-> Maybe
     (Text,
      (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe Int))
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe Int
pinArtifact
        ]

{- | Decide the override refusal from the residual overshoots, and name the culprits.
Refuse only when the override-free minimum fits the heap ceiling (@freeOvershoot@ is
zero) while the pinned plan does not (@overriddenOvershoot@ is positive): the pins are
then the cause, and a pod too small even without them is a degradation the shed
ladder already warned about, never a refusal. Name the pins whose individual removal
makes the plan fit (their one-out overshoot is zero); when none alone flips the
verdict (the pins only overshoot in combination), name them all rather than
under-blame. The message reports only the overshoot the named pins are responsible
for, since the override-free minimum fits within the ceiling.
-}
attributeOverrideViolations :: Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations :: Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations Int
heapCeiling Int
overriddenOvershoot Int
freeOvershoot [(Text, Int)]
perOverrideOvershoot
    | Int
overriddenOvershoot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
freeOvershoot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
        [ Text
"explicit override(s) "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
culprits
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" push the combined memory plan "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
overriddenOvershoot
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes past the effective heap ceiling "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
heapCeiling
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; the override-free minimum fits within it, so lower them or raise the ceiling"
        ]
    | Bool
otherwise = []
  where
    culprits :: [Text]
culprits = case [Text
name | (Text
name, Int
o) <- [(Text, Int)]
perOverrideOvershoot, Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0] of
        [] -> ((Text, Int) -> Text) -> [(Text, Int)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Text
forall a b. (a, b) -> a
fst [(Text, Int)]
perOverrideOvershoot
        [Text]
flips -> [Text]
flips

{- | The metadata cache's tunables: the configured TTL married to the plan's cache
aggregate, split into the three stores' named sub-budgets __summing exactly to the
aggregate__ (the assembled share is the remainder). The shares: the full-packument
store carries the decoded working set at 60%; the single-version store holds small
flat entries at 15% but four times the entry count; the assembled store's encoded
documents take the remaining 25%. A fully-shed (zero) aggregate yields stores that
retain nothing: every value takes the oversized pass-through and the proxy serves
uncached.
-}
planCacheConfig :: CacheSettings -> MemoryPlan -> CacheConfig
planCacheConfig :: CacheSettings -> MemoryPlan -> CacheConfig
planCacheConfig CacheSettings
cacheSettings MemoryPlan
plan =
    CacheConfig
        { cacheTtl :: NominalDiffTime
cacheTtl = CacheSettings -> NominalDiffTime
csTtl CacheSettings
cacheSettings
        , cacheFullBudget :: StoreBudget
cacheFullBudget = StoreBudget{sbMaxEntries :: Int
sbMaxEntries = Int
entries, sbMaxBytes :: Int
sbMaxBytes = Int
fullBytes}
        , cacheVersionBudget :: StoreBudget
cacheVersionBudget = StoreBudget{sbMaxEntries :: Int
sbMaxEntries = Int
cacheVersionEntriesFactor Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
entries, sbMaxBytes :: Int
sbMaxBytes = Int
versionBytes}
        , cacheAssembledBudget :: StoreBudget
cacheAssembledBudget = StoreBudget{sbMaxEntries :: Int
sbMaxEntries = Int
entries, sbMaxBytes :: Int
sbMaxBytes = Int
aggregate Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fullBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
versionBytes}
        }
  where
    aggregate :: Int
aggregate = MemoryPlan -> Int
mpCacheAggregateBytes MemoryPlan
plan
    entries :: Int
entries = MemoryPlan -> Int
mpCacheMaxEntries MemoryPlan
plan
    fullBytes :: Int
fullBytes = Int
aggregate Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cacheFullSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100
    versionBytes :: Int
versionBytes = Int
aggregate Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cacheVersionSharePercent Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100

-- The named split of the cache aggregate, in percent; the assembled store takes
-- the remainder so the three sub-budgets sum to exactly the aggregate.
cacheFullSharePercent :: Int
cacheFullSharePercent :: Int
cacheFullSharePercent = Int
60

cacheVersionSharePercent :: Int
cacheVersionSharePercent :: Int
cacheVersionSharePercent = Int
15

-- The version store's entries are flat and small (16 KiB estimates against the
-- full store's 256 KiB), so it holds several per full entry.
cacheVersionEntriesFactor :: Int
cacheVersionEntriesFactor :: Int
cacheVersionEntriesFactor = Int
4

-- Tenant shares of the application heap (the ceiling less the reserve), summing
-- to 95% so the computed plan fits by construction; floors and explicit
-- overrides are what the shed ladder and the override check answer for.
cacheSharePercent :: Int
cacheSharePercent :: Int
cacheSharePercent = Int
30

materialSharePercent :: Int
materialSharePercent :: Int
materialSharePercent = Int
45

publishSharePercent :: Int
publishSharePercent :: Int
publishSharePercent = Int
15

queueSharePercent :: Int
queueSharePercent :: Int
queueSharePercent = Int
5

-- The mirror-artifact tenant's share of the application heap. Kept modest because the
-- charged envelope is this share (the worker's cap is it, divided by the multiplier),
-- and because the background back-fill leg must not crowd the serve hot path: a normally
-- provisioned pod fits it without shedding, and a larger pod scales the cap up to the cap.
mirrorArtifactSharePercent :: Int
mirrorArtifactSharePercent :: Int
mirrorArtifactSharePercent = Int
4

{- The transient publish envelope one mirrored artifact holds, as a multiple of the
buffered tarball. The worker holds the strict tarball (B), decodes a base64 'Text'
(~4/3 B), and serialises a strict publish document embedding that base64 (~4/3 B plus
lazy chunks), which can coexist before GC at ~3.7x B; rounded up to 4 so the charged
tenant never under-provisions the peak. See issue #846. -}
mirrorArtifactEnvelopeMultiplier :: Int
mirrorArtifactEnvelopeMultiplier :: Int
mirrorArtifactEnvelopeMultiplier = Int
4

-- The computed artifact cap is clamped to this ceiling, which is also the no-ceiling
-- fallback: the shipped 512 MiB bound that predated the plan. The charged envelope is
-- thus at most this times the multiplier even on an enormous pod, and the worker's cap
-- never exceeds what one process could historically buffer.
mirrorArtifactBytesCap :: Int
mirrorArtifactBytesCap :: Int
mirrorArtifactBytesCap = Int
512 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

-- The runtime reserve: a fifth of the ceiling, floored so a tiny pod still
-- leaves the GC and the RTS something to breathe with.
runtimeReserveShareDiv :: Int
runtimeReserveShareDiv :: Int
runtimeReserveShareDiv = Int
5

runtimeReserveFloorBytes :: Int
runtimeReserveFloorBytes :: Int
runtimeReserveFloorBytes = Int
33554432

-- The nursery (capabilities x allocation area) may hold at most this share of
-- the ceiling before the capability count itself is the tenant to shed.
nurseryCeilingShareDiv :: Int
nurseryCeilingShareDiv :: Int
nurseryCeilingShareDiv = Int
4

-- The response-cap floor is the shipped policy value: real-world packuments reach
-- multiple MiB, so a small pod must never compute itself below what is known to
-- admit them. The cap keeps one hostile document from monopolising a huge heap.
responseBytesFloor :: Int
responseBytesFloor :: Int
responseBytesFloor = Int
12582912

responseBytesCap :: Int
responseBytesCap :: Int
responseBytesCap = Int
67108864

responseBytesFallback :: Int
responseBytesFallback :: Int
responseBytesFallback = Int
12582912

requestBytesFloor :: Int
requestBytesFloor :: Int
requestBytesFloor = Int
26214400

requestBytesCap :: Int
requestBytesCap :: Int
requestBytesCap = Int
104857600

requestBytesFallback :: Int
requestBytesFallback :: Int
requestBytesFallback = Int
26214400

-- With no ceiling datapoint the publish aggregate falls back to a few maximum
-- requests' worth of concurrent body room.
publishAggregateFallbackRequests :: Int
publishAggregateFallbackRequests :: Int
publishAggregateFallbackRequests = Int
4

-- A floor so a pod that can afford one still caches a useful working set, a cap
-- because past a gigabyte of decoded metadata the TTL, not memory, is the
-- effective bound. The shed ladder may go below the floor, to zero.
cacheBytesFloor :: Int
cacheBytesFloor :: Int
cacheBytesFloor = Int
67108864

cacheBytesCap :: Int
cacheBytesCap :: Int
cacheBytesCap = Int
1073741824

cacheBytesFallback :: Int
cacheBytesFallback :: Int
cacheBytesFallback = Int
268435456

-- The expected decoded footprint of one cached packument (256 KiB).
cacheEntryExpectedBytes :: Int
cacheEntryExpectedBytes :: Int
cacheEntryExpectedBytes = Int
262144

cacheEntriesFloor :: Int
cacheEntriesFloor :: Int
cacheEntriesFloor = Int
256

cacheEntriesCap :: Int
cacheEntriesCap :: Int
cacheEntriesCap = Int
65536

queueDepthFloor :: Int
queueDepthFloor :: Int
queueDepthFloor = Int
5000

queueDepthCap :: Int
queueDepthCap :: Int
queueDepthCap = Int
100000

queueDepthFallback :: Int
queueDepthFallback :: Int
queueDepthFallback = Int
50000