chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] catch exceptions in finalizers, remove dynamic


From: Felix
Subject: [Chicken-hackers] [PATCH] catch exceptions in finalizers, remove dynamic resizing of finalizer vector
Date: Tue, 19 Jun 2012 11:35:36 +0200 (CEST)

The attached patch adds exception handling around the invocation of
finalizers, which are shown as warnings (unless warnings are disabled)
but do not otherwise trigger errors (similar to the way errors in
separate threads are handled). I still experienced random crashes when
running the stress test in #866. What helped was removing the dynamic
resizing of the vector stored in ##sys#pending-finalizers.  I could
not found a decent explanation for this but having a vector of fixed
size made the crashes go away. I assume there is some race-condition
between code that runs pending finalizers and code that creates new
ones ("set-finalizer!"). This means the number of finalizers is
limited to (currently) 4096. Code that produces many finalizers must
make sure they are triggered (and thus un-registered) fast enough.
Note that the "-:f" runtime option can be used to change the number of
available finalizers.


cheers,
felix
>From fcadbb82750d10d0c01178ffe603d9b5cfcf1731 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 14 Jun 2012 09:34:25 +0200
Subject: [PATCH] Catch exceptions in finalizers and added tests.
 Resizing of the finalizer-table has been removed. There can be at most
 4096 live finalizers (can be changed by using -:f).

---
 chicken.h                      |    1 -
 distribution/manifest          |    1 +
 library.scm                    |   49 ++++++++++++++++++++++++++++-----------
 runtime.c                      |   14 -----------
 scheduler.scm                  |   47 ++++++++++++++-----------------------
 tests/finalizer-error-test.scm |   17 ++++++++++++++
 tests/runtests.sh              |    4 +-
 7 files changed, 73 insertions(+), 60 deletions(-)
 create mode 100644 tests/finalizer-error-test.scm

diff --git a/chicken.h b/chicken.h
index 837a51c..62dd1bc 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1563,7 +1563,6 @@ C_fctexport void C_fcall 
C_paranoid_check_for_interrupt(void) C_regparm;
 C_fctexport void C_zap_strings(C_word str);
 C_fctexport void C_set_or_change_heap_size(C_word heap, int reintern);
 C_fctexport void C_do_resize_stack(C_word stack);
-C_fctexport C_word C_resize_pending_finalizers(C_word size);
 C_fctexport void C_initialize_lf(C_word *lf, int count);
 C_fctexport void *C_register_lf(C_word *lf, int count);
 C_fctexport void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY 
*ptable);
diff --git a/distribution/manifest b/distribution/manifest
index 6c02c34..02bc6ec 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -189,6 +189,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..3387924 100644
--- a/library.scm
+++ b/library.scm
@@ -4574,18 +4574,13 @@ EOF
 (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) ) ) )
+      (when (##sys#fudge 13)
+       (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing 
...") )
+      (##sys#force-finalizers) 
+      (when (fx> (##sys#fudge 26) _max_pending_finalizers)
+       (##sys#signal-hook
+        #:memory-error 'set-finalizer! 
+        "maximal finalizer-count exceeded")))
     (##sys#set-finalizer! x y) ) )
 
 (define ##sys#run-pending-finalizers
@@ -4601,8 +4596,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 +4738,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/runtime.c b/runtime.c
index ced344b..bdaa335 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1108,20 +1108,6 @@ void C_check_nursery_minimum(C_word words)
     panic(C_text("nursery is too small - try higher setting using the `-:s' 
option"));
 }
 
-C_word C_resize_pending_finalizers(C_word size) {
-  int sz = C_num_to_int(size);
-
-  FINALIZER_NODE **newmem = 
-    (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * 
sizeof(FINALIZER_NODE *));
-  
-  if (newmem == NULL)
-    return C_SCHEME_FALSE;
-
-  pending_finalizer_indices = newmem;
-  C_max_pending_finalizers = sz;
-  return C_SCHEME_TRUE;
-}
-
 
 /* Parse runtime options from command-line: */
 
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/finalizer-error-test.scm b/tests/finalizer-error-test.scm
new file mode 100644
index 0000000..cf24da9
--- /dev/null
+++ b/tests/finalizer-error-test.scm
@@ -0,0 +1,17 @@
+;;;; finalizer-error-test.scm - by "megane"
+
+(define n 10000)
+
+(define (make-objects n)
+  (let loop [(i 0)]
+    (let [(o (make-vector 100))]
+      ;(print "making " i)
+      (set-finalizer! o (lambda (ob) (print* " " i)))
+      (if (< i n)
+         (loop (+ 1 i))))))
+
+(set-finalizer! (make-vector 100) (lambda (ob) (+ i 'a)))
+
+(make-objects n)
+
+(print "done")
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 9f9f7ee..323c370 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -341,8 +341,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


reply via email to

[Prev in Thread] Current Thread [Next in Thread]