2021-06-08 07:33:56 +00:00
|
|
|
#lang syndicate
|
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
2022-01-16 08:48:18 +00:00
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-08 07:33:56 +00:00
|
|
|
|
|
|
|
(provide linked-thread)
|
|
|
|
|
|
|
|
(require "engine.rkt")
|
2021-06-08 14:37:40 +00:00
|
|
|
(require (only-in racket/exn exn->string))
|
2021-06-08 07:33:56 +00:00
|
|
|
|
|
|
|
(define-logger syndicate/driver-support)
|
|
|
|
|
2021-06-10 11:29:19 +00:00
|
|
|
(define (linked-thread thread-proc
|
2021-06-10 09:42:07 +00:00
|
|
|
#:name [name (gensym 'linked-thread)]
|
2021-06-10 11:29:19 +00:00
|
|
|
#:peer [peer (ref (entity/stop-on-retract #:name (list name 'monitor)))]
|
2021-06-17 13:26:14 +00:00
|
|
|
#:custodian [c0 #f])
|
|
|
|
(define c (or c0 (make-custodian)))
|
|
|
|
|
2021-06-17 11:38:30 +00:00
|
|
|
(define facet this-facet)
|
|
|
|
(define actor this-actor)
|
|
|
|
|
2021-06-10 09:42:07 +00:00
|
|
|
(define handle #f)
|
|
|
|
(define armed? #t)
|
|
|
|
|
|
|
|
(define (!)
|
|
|
|
(when armed?
|
|
|
|
(log-syndicate/driver-support-info "~a shutdown" name)
|
2021-06-17 11:38:30 +00:00
|
|
|
(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 !)))
|
2021-06-10 09:42:07 +00:00
|
|
|
|
|
|
|
(on-stop (!))
|
2021-06-17 11:38:30 +00:00
|
|
|
(actor-add-exit-hook! actor !)
|
2021-06-10 09:42:07 +00:00
|
|
|
|
|
|
|
(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))
|
2021-06-17 11:38:30 +00:00
|
|
|
(!))))))))
|