cs: fix interaction of places and 'GC log receivers

Related to #3174
This commit is contained in:
Matthew Flatt 2020-05-11 09:45:52 -06:00
parent 0e6415899b
commit 9ab5ba0fbc
2 changed files with 41 additions and 12 deletions

View File

@ -0,0 +1,25 @@
#lang racket/base
(require racket/place)
(define (churn n)
(let loop ([l (cons "" 0)])
(if (equal? (cdr l) n)
(string-length (car l))
(loop (cons (make-string 512 #\x)
(add1 (cdr l)))))))
(define (go)
(place pch
(churn 100000)))
(module+ main
(go)
(define receiver
(make-log-receiver (current-logger) 'debug 'GC))
(void
(thread
(lambda ()
(let loop ()
(sync receiver)
(loop)))))
(churn 100000))

View File

@ -1,20 +1,24 @@
#lang racket/base
(require "atomic.rkt"
"host.rkt")
"host.rkt"
"place-object.rkt")
(provide unsafe-add-pre-poll-callback!
call-pre-poll-external-callbacks)
;; Callbacks for the original place only:
(define pre-poll-callbacks null)
;; called in atomic mode in an arbitrary host thread, but
;; Called in atomic mode in an arbitrary host thread, but
;; with all other host threads paused; the given procedure
;; will be called in atomic mode, possibly in the schduler
;; will be called in atomic mode, possibly in the schduler,
;; in the original place
(define (unsafe-add-pre-poll-callback! proc)
(set! pre-poll-callbacks (cons proc pre-poll-callbacks)))
;; in atomic mode
(define (call-pre-poll-external-callbacks)
(when (eq? current-place initial-place)
(unless (null? pre-poll-callbacks)
;; disable interrupts to avoid a case with `unsafe-add-pre-poll-callback!`
(host:disable-interrupts)
@ -23,4 +27,4 @@
(host:enable-interrupts)
;; Call the callbacks
(for ([cb (in-list (reverse l))])
(cb))))
(cb)))))