[Chicken-hackers] [PATCH] catch errors in finalizer code

[Felix]

As Christian as suggested, I split the recent finalizer-related
patch in two. Here is the catching of errors in finalizers.


cheers,
felix

>From 6afc54c36f89ca3ade70180b4656921f19e63939 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 22 Jun 2012 17:20:47 +0200
Subject: [PATCH] Exceptions signalled by code that executes in finalizers will 
now
 be caught and do not propagate upwards into arbitrary user code.

---
 distribution/manifest |    1 +
 library.scm           |   30 ++++++++++++++++++++++++++++--
 scheduler.scm         |   47 ++++++++++++++++++-----------------------------
 tests/runtests.sh     |    4 ++--
 4 files changed, 49 insertions(+), 33 deletions(-)

diff --git a/distribution/manifest b/distribution/manifest
index d4b641b..b71da35 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -190,6 +190,7 @@ tests/functor-tests.scm
 tests/square-functor.scm
 tests/use-square-functor.scm
 tests/pp-test.scm
+tests/finalizer-error-test.scm
 tests/reverser/tags/1.0/reverser.meta
 tests/reverser/tags/1.0/reverser.setup
 tests/reverser/tags/1.0/reverser.scm
diff --git a/library.scm b/library.scm
index 030fad8..90d22c6 100644
--- a/library.scm
+++ b/library.scm
@@ -4601,8 +4601,10 @@ EOF
          (do ([i 0 (fx+ i 1)])
              ((fx>= i c))
            (let ([i2 (fx+ 1 (fx* i 2))])
-             ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
-              (##sys#slot ##sys#pending-finalizers i2)) ) )
+             (handle-exceptions ex
+                 (##sys#show-exception-warning ex "in finalizer" #f)
+               ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
+                (##sys#slot ##sys#pending-finalizers i2)) ) ))
          (vector-fill! ##sys#pending-finalizers (##core#undefined))
          (##sys#setislot ##sys#pending-finalizers 0 0) 
          (set! working #f) ) )
@@ -4741,6 +4743,30 @@ EOF
               (writeargs (list ex) port) ] ) ) ) ) )
 
 
+;;; Show exception message and backtrace as warning
+;;; (used for threads and finalizers)
+
+(define ##sys#show-exception-warning
+  (let ((print-error-message print-error-message)
+       (display display)
+       (write-char write-char)
+       (print-call-chain print-call-chain)
+       (open-output-string open-output-string)
+       (get-output-string get-output-string) )
+    (lambda (exn cause #!optional (thread ##sys#current-thread))
+      (when ##sys#warnings-enabled
+       (let ((o (open-output-string)))
+         (display "Warning" o)
+         (when thread
+           (display " (" o)
+           (display thread o)
+           (write-char #\) o))
+         (display ": " o)
+         (display cause o)
+         (print-error-message exn ##sys#standard-error (get-output-string o))
+         (print-call-chain ##sys#standard-error 0 thread) ) ))))
+
+
 ;;; We need this here so `location' works:
  
 (define (##sys#make-locative obj index weak? loc)
diff --git a/scheduler.scm b/scheduler.scm
index e3a96bc..d3a2620 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -309,35 +309,24 @@ EOF
   (##sys#setislot t 4 #f)
   (##sys#add-to-ready-queue t) )
 
-(define ##sys#default-exception-handler
-  (let ([print-error-message print-error-message]
-       [display display]
-       [print-call-chain print-call-chain]
-       [open-output-string open-output-string]
-       [get-output-string get-output-string] )
-    (lambda (arg)
-      (let ([ct ##sys#current-thread])
-       (dbg "exception: " ct " -> " 
-            (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
-       (cond [(foreign-value "C_abort_on_thread_exceptions" bool)
-              (let* ([pt ##sys#primordial-thread]
-                     [ptx (##sys#slot pt 1)] )
-                (##sys#setslot 
-                 pt 1 
-                 (lambda ()
-                   (##sys#signal arg)
-                   (ptx) ) )
-                (##sys#thread-unblock! pt) ) ]
-             [##sys#warnings-enabled
-              (let ([o (open-output-string)])
-                (display "Warning (" o)
-                (display ct o)
-                (display ")" o)
-                (print-error-message arg ##sys#standard-error 
(get-output-string o))
-                (print-call-chain ##sys#standard-error 0 ct) ) ] )
-       (##sys#setslot ct 7 arg)
-       (##sys#thread-kill! ct 'terminated)
-       (##sys#schedule) ) ) ) )
+(define (##sys#default-exception-handler arg)
+  (let ([ct ##sys#current-thread])
+    (dbg "exception: " ct " -> " 
+        (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
+    (cond ((foreign-value "C_abort_on_thread_exceptions" bool)
+          (let* ([pt ##sys#primordial-thread]
+                 [ptx (##sys#slot pt 1)] )
+            (##sys#setslot 
+             pt 1 
+             (lambda ()
+               (##sys#signal arg)
+               (ptx) ) )
+            (##sys#thread-unblock! pt) ) )
+         (else
+          (##sys#show-exception-warning arg "in thread" ct)))
+    (##sys#setslot ct 7 arg)
+    (##sys#thread-kill! ct 'terminated)
+    (##sys#schedule) ) )
 
 
 ;;; `select()'-based blocking:
diff --git a/tests/runtests.sh b/tests/runtests.sh
index d21b704..63790ef 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -344,8 +344,8 @@ $compile symbolgc-tests.scm
 
 echo "======================================== finalizer tests ..."
 $interpret -s test-finalizers.scm
-
-echo "======================================== finalizer tests (2) ..."
+$compile finalizer-error-test.scm
+./a.out
 $compile test-finalizers-2.scm
 ./a.out
 
-- 
1.6.0.4