Re: [Chicken-hackers] [PATCH] catch exceptions in finalizers, remove dynamic resizing of finalizer vector

[Jim Ursetto]

Might I suggest that these nice thorough explanations be put in the
patch message itself (preceded by a blank line), so we always
have them at hand.

On Jun 19, 2012, at 4:35 AM, Felix wrote:

> 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
> 
> _______________________________________________
> Chicken-hackers mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers