luv

Workshop wiki

production.lisp

production/production.lisp

system luv/production · 17 definitions · on GitHub

A deliberately small owner/worker production boundary.

in-package#:luv.production
math:define-quantity:production-duration:kind:duration:non-negative-pt
defclassproduction-request
key:initarg:key:readerproduction-request-key
priority:initarg:priority:initform0:readerproduction-request-priority
ticket:initformnil:accessorproduction-request-ticket
:documentation

An inspectable immutable unit of CPU work after it is submitted.

defgenericperform-production-request
request
:documentation

Compute request on the production worker and return a transferable value.

defclassproduction-result
request:initarg:request:readerproduction-result-request
value:initarg:value:initformnil:readerproduction-result-value
condition:initarg:condition:initformnil:readerproduction-result-condition
elapsed-seconds:initarg:elapsed-seconds:typedouble-float:quantity
:quantity:production-duration:unit:second
:readerproduction-result-elapsed-seconds
defclasssingle-worker-production-system
name:initarg:name:readerproduction-system-name
request-mailbox:readerproduction-system-request-mailbox
result-mailbox:readerproduction-system-result-mailbox
lock:readerproduction-system-lock

DESIRED is a latest-value map, not a history queue. Scheduling the same semantic key replaces work which has not started yet.

desired:readerproduction-system-desired
wake-p:initformnil:accessorproduction-system-wake-p
active-request:initformnil:accessorproduction-system-active-request
next-ticket:initform0:accessorproduction-system-next-ticket
running-p:initformt:accessorproduction-system-running-p
thread:initformnil:accessorproduction-system-thread
defunproduction-system-request-better-p
leftright
or
<
production-request-priorityleft
production-request-priorityright
and
=
production-request-priorityleft
production-request-priorityright
<
production-request-ticketleft
production-request-ticketright
zdefun
take-production-system-request:zone:production/take-request
system
sb-thread:with-mutex
production-system-locksystem
setf
production-system-wake-psystem
nil
let
bestnil
maphash
lambda
keyrequest
declare
ignorekey
when
setfbestrequest
production-system-desiredsystem
whenbest
remhash
production-request-keybest
production-system-desiredsystem
best
defunwake-production-system-if-needed
system
let
wake-pnil
sb-thread:with-mutex
production-system-locksystem
when
and
production-system-running-psystem
plusp
hash-table-count
production-system-desiredsystem

One completed value is the publication backpressure frontier. The owner must receive it before the worker begins another request, so result memory stays bounded even when rendering pauses.

sb-concurrency:mailbox-empty-p
production-system-result-mailboxsystem
not
production-system-wake-psystem
setf
production-system-wake-psystem
t
wake-pt
whenwake-p
sb-concurrency:send-message
production-system-request-mailboxsystem
:work
defunrun-production-system
system
name-tracy-thread
production-system-namesystem
loop
multiple-value-bind
messagereceived-p
sb-concurrency:receive-message
production-system-request-mailboxsystem
declare
ignorereceived-p
ecasemessage
:stop
:work
let
whenrequest
let*
start
get-internal-real-time
valuenil
conditionnil
with-cpu-trace-zone
:production/perform
handler-case
error
caught
setfconditioncaught
sb-concurrency:send-message
production-system-result-mailboxsystem
make-instance'production-result:requestrequest:valuevalue:conditioncondition:elapsed-seconds
/
-
get-internal-real-time
start
coerceinternal-time-units-per-second'double-float
sb-thread:with-mutex
production-system-locksystem
defunmake-single-worker-production-system
&key
name"luv single CPU producer"

Make one sleeping SB-CONCURRENCY mailbox worker.

There is intentionally no pool yet. One worker proves the ownership and publication protocol, prevents CPU oversubscription, and keeps completion order intelligible while taking expensive work out of an owner callback.

let
system
make-instance'single-worker-production-system:namename
setf
slot-valuesystem'request-mailbox
sb-concurrency:make-mailbox:name
formatnil"~A requests"name
slot-valuesystem'result-mailbox
sb-concurrency:make-mailbox:name
formatnil"~A results"name
slot-valuesystem'lock
sb-thread:make-mutex:name
formatnil"~A state"name
slot-valuesystem'desired
make-hash-table:test#'equal
production-system-threadsystem
sb-thread:make-thread:namename
system
zdefun
schedule-production-request:zone:production/schedule
systemrequest
"Schedule the latest REQUEST for its semantic key and return its ticket."
check-typerequestproduction-request
sb-thread:with-mutex
production-system-locksystem
unless
production-system-running-psystem
error"Production system ~A has stopped."
production-system-namesystem
setf
production-request-ticketrequest
incf
production-system-next-ticketsystem
gethash
production-request-keyrequest
production-system-desiredsystem
request
production-request-ticketrequest
defunproduction-request-pending-p
systemkey

Whether key is desired or presently executing.

sb-thread:with-mutex
production-system-locksystem
or
nth-value1
gethashkey
production-system-desiredsystem
let
andactive
equalkey
production-request-keyactive
defuncancel-production-request
systemkey

Cancel work for key if it has not begun; active results remain discardable.

sb-thread:with-mutex
production-system-locksystem
remhashkey
production-system-desiredsystem
defunreceive-production-result-no-hang
system
multiple-value-bind
resultpresent-p
sb-concurrency:receive-message-no-hang
production-system-result-mailboxsystem
valuesresultpresent-p
defunproduction-system-completed-count
system

Return the number of completed results waiting for their owner.

sb-concurrency:mailbox-count
production-system-result-mailboxsystem
defunproduction-system-pending-count
system
sb-thread:with-mutex
production-system-locksystem
+
hash-table-count
production-system-desiredsystem
defunstop-production-system
system&key
timeout10.0

Cooperatively stop system after its active request, then join its worker.

let
stop-pnil
sb-thread:with-mutex
production-system-locksystem
when
production-system-running-psystem
setf
production-system-running-psystem
nil
stop-pt
clrhash
production-system-desiredsystem
whenstop-p
sb-concurrency:send-message
production-system-request-mailboxsystem
:stop
multiple-value-bind
valuestate
sb-thread:join-thread
production-system-threadsystem
:timeouttimeout:default:timeout
declare
ignorevalue
when
eqstate:timeout
error"Production worker ~A did not stop within ~,2F seconds."
production-system-namesystem
timeout
nil