[Chicken-hackers] [PATCH] debugging output for finalizers gets written to stdout

[Felix Winkelmann]

It turns out that debugging output enabled with the "-:d" option
writes information specific to finalizer-queue management to stdout,
interfering with whatever port happens to be the current standrd
output port, and particularly nasty when using "with-output-to-string"
and friends. The attached patch changes the code to output to stderr
instead.

This can produce rather ugly bugs, I recommend to add this to the
stability branch.


felix

>From d66f066a47bdcafaec6a0e88088080f91e32432e Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Wed, 28 Aug 2013 22:07:30 +0200
Subject: [PATCH] debugging output for finalizer-management blindly wrote to
 stdout, which could interfere with code that uses
 with-output-to-string, for example.

---
 library.scm |   54 +++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 35 insertions(+), 19 deletions(-)

diff --git a/library.scm b/library.scm
index 5a2862e..a1f0470 100644
--- a/library.scm
+++ b/library.scm
@@ -4648,32 +4648,48 @@ EOF
 (define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))
 
 (define set-finalizer! 
-  (lambda (x y)
-    (when (fx>= (##sys#fudge 26) _max_pending_finalizers)
-      (if (##core#inline "C_resize_pending_finalizers" (fx* 2 
_max_pending_finalizers))
-         (begin
-           (set! ##sys#pending-finalizers (##sys#grow-vector 
##sys#pending-finalizers
-                                                             (fx+ (fx* 2 
_max_pending_finalizers) 1)
-                                                             
(##core#undefined)))
-           (when (##sys#fudge 13)
-             (print "[debug] too many finalizers (" (##sys#fudge 26)
-                    "), resized max finalizers to " _max_pending_finalizers 
"...") ) )
-         (begin
-           (when (##sys#fudge 13)
-             (print "[debug] too many finalizers (" (##sys#fudge 26) "), 
forcing ...") )
-           (##sys#force-finalizers) ) ) )
-    (##sys#set-finalizer! x y) ) )
+  (let ((string-append string-append))
+    (lambda (x y)
+      (when (fx>= (##sys#fudge 26) _max_pending_finalizers)
+       (cond ((##core#inline "C_resize_pending_finalizers" (fx* 2 
_max_pending_finalizers))
+              (set! ##sys#pending-finalizers (##sys#grow-vector 
##sys#pending-finalizers
+                                                                (fx+ (fx* 2 
_max_pending_finalizers) 1)
+                                                                
(##core#undefined)))
+              (when (##sys#fudge 13)
+                (##sys#print 
+                 (string-append
+                  "[debug] too many finalizers (" 
+                  (##sys#number->string (##sys#fudge 26))
+                  "), resized max finalizers to "
+                  (##sys#number->string _max_pending_finalizers)
+                  "\n")
+                 #f ##sys#standard-error)))
+             (else
+              (when (##sys#fudge 13)
+                (##sys#print 
+                 (string-append
+                  "[debug] too many finalizers ("
+                  (##sys#fudge 26)
+                  "), forcing ...\n")
+                 #f ##sys#standard-error))
+              (##sys#force-finalizers) ) ) )
+      (##sys#set-finalizer! x y) ) ) )
 
 (define ##sys#run-pending-finalizers
-  (let ([vector-fill! vector-fill!]
-       [working #f] )
+  (let ((vector-fill! vector-fill!)
+       (string-append string-append)
+       (working #f) )
     (lambda (state)
       (unless working
        (set! working #t)
        (let* ((c (##sys#slot ##sys#pending-finalizers 0)) )
          (when (##sys#fudge 13)
-           (print "[debug] running " c " finalizer(s) (" (##sys#fudge 26) " 
live, "
-                  (##sys#fudge 27) " allocated) ..."))
+           (##sys#print 
+            (string-append "[debug] running " (##sys#number->string c)
+                           " finalizer(s) (" (##sys#number->string 
(##sys#fudge 26))
+                           " live, " (##sys#number->string (##sys#fudge 27))
+                           " allocated) ...\n")
+            #f ##sys#standard-error))
          (do ([i 0 (fx+ i 1)])
              ((fx>= i c))
            (let ([i2 (fx+ 1 (fx* i 2))])
-- 
1.7.9.5