syndicate-rkt/syndicate/driver-support.rkt

51 lines
1.8 KiB
Racket

#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(provide linked-thread)
(require "engine.rkt")
(require (only-in racket/exn exn->string))
(define-logger syndicate/driver-support)
(define (linked-thread thread-proc
#:name [name (gensym 'linked-thread)]
#:peer [peer (ref (entity/stop-on-retract #:name (list name 'monitor)))]
#:custodian [c0 #f])
(define c (or c0 (make-custodian)))
(define facet this-facet)
(define actor this-actor)
(define handle #f)
(define armed? #t)
(define (!)
(when armed?
(log-syndicate/driver-support-info "~a shutdown" name)
(set! armed? #f)
(turn! facet (lambda () (turn-retract! this-turn handle)))
(queue-task! (actor-engine actor) (lambda () (custodian-shutdown-all c)))
(actor-remove-exit-hook! actor !)))
(on-stop (!))
(actor-add-exit-hook! actor !)
(log-syndicate/driver-support-info "~a startup" name)
(set! handle
(parameterize ((current-custodian c))
(turn-assert! this-turn
peer
(embedded
(thread (lambda ()
(with-handlers
([(lambda (_e) #t)
(lambda (e)
(log-syndicate/driver-support-error "~a crashed:\n~a"
name
(exn->string e))
(void))])
(thread-proc facet))
(!))))))))