[Chicken-hackers] [PATCH] Fix couple of hangs related to finalizers and (gc #t)

[megane]

Hi,

Here's a fix for #1586.

You can trigger the second case with this (run compiled):

  (cond-expand
   (chicken-5 (import (chicken base))
              (import chicken.gc))
   (else (import chicken)))

  (let ([o (vector)])
    (set-finalizer! o (lambda (_)
                        (print "in finalizer")
                        (gc #t)))
    (print o))
  (gc #t)
  (print "done")

>From 752ebde3e6bd66c6ef306c43c673a5883e0bf829 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Fri, 9 Aug 2019 13:39:36 +0300
Subject: [PATCH] Fix couple of hangs related to finalizers and (gc #t)

Calling (gc #t) would get into an infinite no-progress loop in
was being run in another thread.

In that case the (##sys#run-pending-finalizers #f) call in
is compiled with interrupts disabled the other thread never got to run
again.

* library.scm (##sys#run-pending-finalizers): Yield the current thread
  if pending finalizers are being run in another thread.

  Also signal an error if trying to re-enter. This also would cause an
  infinite loop (when calling (gc #t) inside a finalizer). It would
  need special handling if re-entry is to be supported.

Fixes #1586
---
 library.scm | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/library.scm b/library.scm
index bc0ef42c..b4b7b756 100644
--- a/library.scm
+++ b/library.scm
@@ -6072,10 +6072,11 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
 (define ##sys#run-pending-finalizers
   (let ((vector-fill! vector-fill!)
        (string-append string-append)
-       (working #f) )
+       (working-thread #f) )
     (lambda (state)
-      (unless working
-       (set! working #t)
+      (cond
+       ((not working-thread)
+       (set! working-thread ##sys#current-thread)
        (let* ((c (##sys#slot ##sys#pending-finalizers 0)) )
          (when (##sys#debug-mode?)
            (##sys#print 
@@ -6097,7 +6098,14 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
                 (##sys#slot ##sys#pending-finalizers i2)) ) ))
          (vector-fill! ##sys#pending-finalizers (##core#undefined))
          (##sys#setislot ##sys#pending-finalizers 0 0) 
-         (set! working #f) ) )
+         (set! working-thread #f)))
+       ((eq? working-thread ##sys#current-thread)
+        (##sys#signal-hook
+         #:error '##sys#run-pending-finalizers
+         "re-entry from finalizer thread (maybe (gc #t) was called from a 
finalizer)"))
+       (else
+       ;; Give finalizer thread a change to run
+       (##sys#thread-yield!)))
       (cond ((not state))
            ((procedure? state) (state))
            (state (##sys#context-switch state) ) ) ) ))
-- 
2.17.1