Ticket #866: 0001-Catch-exceptions-in-finalizers-and-added-tests.patch

File 0001-Catch-exceptions-in-finalizers-and-added-tests.patch, 8.0 KB (added by felix winkelmann, 12 years ago)

better variant

  • chicken.h 

    From fcadbb82750d10d0c01178ffe603d9b5cfcf1731 Mon Sep 17 00:00:00 2001
From: felix <felix@call-with-current-continuation.org>
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 b C_fctexport void C_fcall C_paranoid_check_for_interrupt(void) C_regparm; 
    15631563C_fctexport void C_zap_strings(C_word str);
    15641564C_fctexport void C_set_or_change_heap_size(C_word heap, int reintern);
    15651565C_fctexport void C_do_resize_stack(C_word stack);
    1566 C_fctexport C_word C_resize_pending_finalizers(C_word size);
    15671566C_fctexport void C_initialize_lf(C_word *lf, int count);
    15681567C_fctexport void *C_register_lf(C_word *lf, int count);
    15691568C_fctexport void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable);

  • distribution/manifest 

    diff --git a/distribution/manifest b/distribution/manifest
index 6c02c34..02bc6ec 100644
    a b tests/functor-tests.scm 
    189189tests/square-functor.scm
    190190tests/use-square-functor.scm
    191191tests/pp-test.scm
     192tests/finalizer-error-test.scm
    192193tests/reverser/tags/1.0/reverser.meta
    193194tests/reverser/tags/1.0/reverser.setup
    194195tests/reverser/tags/1.0/reverser.scm

  • library.scm 

    diff --git a/library.scm b/library.scm
index 030fad8..3387924 100644
    a b EOF 
    45744574(define set-finalizer!
    45754575  (lambda (x y)
    45764576    (when (fx> (##sys#fudge 26) _max_pending_finalizers)
    4577       (if (##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))
    4578           (begin
    4579             (set! ##sys#pending-finalizers (##sys#grow-vector ##sys#pending-finalizers
    4580                                                               (fx+ (fx* 2 _max_pending_finalizers) 1)
    4581                                                               (##core#undefined)))
    4582             (when (##sys#fudge 13)
    4583               (print "[debug] too many finalizers (" (##sys#fudge 26)
    4584                      "), resized max finalizers to " _max_pending_finalizers "...") ) )
    4585           (begin
    4586             (when (##sys#fudge 13)
    4587               (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing ...") )
    4588             (##sys#force-finalizers) ) ) )
     4577      (when (##sys#fudge 13)
     4578        (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing ...") )
     4579      (##sys#force-finalizers)
     4580      (when (fx> (##sys#fudge 26) _max_pending_finalizers)
     4581        (##sys#signal-hook
     4582         #:memory-error 'set-finalizer!
     4583         "maximal finalizer-count exceeded")))
    45894584    (##sys#set-finalizer! x y) ) )
    45904585
    45914586(define ##sys#run-pending-finalizers
    … … EOF 
    46014596          (do ([i 0 (fx+ i 1)])
    46024597              ((fx>= i c))
    46034598            (let ([i2 (fx+ 1 (fx* i 2))])
    4604               ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
    4605                (##sys#slot ##sys#pending-finalizers i2)) ) )
     4599              (handle-exceptions ex
     4600                  (##sys#show-exception-warning ex "in finalizer" #f)
     4601                ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
     4602                 (##sys#slot ##sys#pending-finalizers i2)) ) ))
    46064603          (vector-fill! ##sys#pending-finalizers (##core#undefined))
    46074604          (##sys#setislot ##sys#pending-finalizers 0 0)
    46084605          (set! working #f) ) )
    … … EOF 
    47414738               (writeargs (list ex) port) ] ) ) ) ) )
    47424739
    47434740
     4741;;; Show exception message and backtrace as warning
     4742;;; (used for threads and finalizers)
     4743
     4744(define ##sys#show-exception-warning
     4745  (let ((print-error-message print-error-message)
     4746        (display display)
     4747        (write-char write-char)
     4748        (print-call-chain print-call-chain)
     4749        (open-output-string open-output-string)
     4750        (get-output-string get-output-string) )
     4751    (lambda (exn cause #!optional (thread ##sys#current-thread))
     4752      (when ##sys#warnings-enabled
     4753        (let ((o (open-output-string)))
     4754          (display "Warning" o)
     4755          (when thread
     4756            (display " (" o)
     4757            (display thread o)
     4758            (write-char #\) o))
     4759          (display ": " o)
     4760          (display cause o)
     4761          (print-error-message exn ##sys#standard-error (get-output-string o))
     4762          (print-call-chain ##sys#standard-error 0 thread) ) ))))
     4763
     4764
    47444765;;; We need this here so `location' works:
    47454766 
    47464767(define (##sys#make-locative obj index weak? loc)

  • runtime.c 

    diff --git a/runtime.c b/runtime.c
index ced344b..bdaa335 100644
    a b void C_check_nursery_minimum(C_word words) 
    11081108    panic(C_text("nursery is too small - try higher setting using the `-:s' option"));
    11091109}
    11101110
    1111 C_word C_resize_pending_finalizers(C_word size) {
    1112   int sz = C_num_to_int(size);
    1113 
    1114   FINALIZER_NODE **newmem =
    1115     (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));
    1116  
    1117   if (newmem == NULL)
    1118     return C_SCHEME_FALSE;
    1119 
    1120   pending_finalizer_indices = newmem;
    1121   C_max_pending_finalizers = sz;
    1122   return C_SCHEME_TRUE;
    1123 }
    1124 
    11251111
    11261112/* Parse runtime options from command-line: */
    11271113

  • scheduler.scm 

    diff --git a/scheduler.scm b/scheduler.scm
index e3a96bc..d3a2620 100644
    a b EOF 
    309309  (##sys#setislot t 4 #f)
    310310  (##sys#add-to-ready-queue t) )
    311311
    312 (define ##sys#default-exception-handler
    313   (let ([print-error-message print-error-message]
    314         [display display]
    315         [print-call-chain print-call-chain]
    316         [open-output-string open-output-string]
    317         [get-output-string get-output-string] )
    318     (lambda (arg)
    319       (let ([ct ##sys#current-thread])
    320         (dbg "exception: " ct " -> "
    321              (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
    322         (cond [(foreign-value "C_abort_on_thread_exceptions" bool)
    323                (let* ([pt ##sys#primordial-thread]
    324                       [ptx (##sys#slot pt 1)] )
    325                  (##sys#setslot
    326                   pt 1
    327                   (lambda ()
    328                     (##sys#signal arg)
    329                     (ptx) ) )
    330                  (##sys#thread-unblock! pt) ) ]
    331               [##sys#warnings-enabled
    332                (let ([o (open-output-string)])
    333                  (display "Warning (" o)
    334                  (display ct o)
    335                  (display ")" o)
    336                  (print-error-message arg ##sys#standard-error (get-output-string o))
    337                  (print-call-chain ##sys#standard-error 0 ct) ) ] )
    338         (##sys#setslot ct 7 arg)
    339         (##sys#thread-kill! ct 'terminated)
    340         (##sys#schedule) ) ) ) )
     312(define (##sys#default-exception-handler arg)
     313  (let ([ct ##sys#current-thread])
     314    (dbg "exception: " ct " -> "
     315         (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
     316    (cond ((foreign-value "C_abort_on_thread_exceptions" bool)
     317           (let* ([pt ##sys#primordial-thread]
     318                  [ptx (##sys#slot pt 1)] )
     319             (##sys#setslot
     320              pt 1
     321              (lambda ()
     322                (##sys#signal arg)
     323                (ptx) ) )
     324             (##sys#thread-unblock! pt) ) )
     325          (else
     326           (##sys#show-exception-warning arg "in thread" ct)))
     327    (##sys#setslot ct 7 arg)
     328    (##sys#thread-kill! ct 'terminated)
     329    (##sys#schedule) ) )
    341330
    342331
    343332;;; `select()'-based blocking:

  • new file tests/finalizer-error-test.scm 

    diff --git a/tests/finalizer-error-test.scm b/tests/finalizer-error-test.scm
new file mode 100644
index 0000000..cf24da9
    - +  
     1;;;; finalizer-error-test.scm - by "megane"
     2
     3(define n 10000)
     4
     5(define (make-objects n)
     6  (let loop [(i 0)]
     7    (let [(o (make-vector 100))]
     8      ;(print "making " i)
     9      (set-finalizer! o (lambda (ob) (print* " " i)))
     10      (if (< i n)
     11          (loop (+ 1 i))))))
     12
     13(set-finalizer! (make-vector 100) (lambda (ob) (+ i 'a)))
     14
     15(make-objects n)
     16
     17(print "done")

  • tests/runtests.sh 

    diff --git a/tests/runtests.sh b/tests/runtests.sh
index 9f9f7ee..323c370 100755
    a b $compile symbolgc-tests.scm 
    341341
    342342echo "======================================== finalizer tests ..."
    343343$interpret -s test-finalizers.scm
    344 
    345 echo "======================================== finalizer tests (2) ..."
     344$compile finalizer-error-test.scm
     345./a.out
    346346$compile test-finalizers-2.scm
    347347./a.out
    348348