Skip to content
Browse files

Exceptions signalled by code that executes in finalizers will now be …

…caught and do not propagate upwards into arbitrary user code.

Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
(cherry picked from commit 8a6d9a4)
  • Loading branch information...
1 parent a77ae51 commit 70d90bcf689b294a7e02696f210a7e85ed555f99 @bunny351 bunny351 committed with Jun 22, 2012
Showing with 49 additions and 33 deletions.
  1. +1 −0 distribution/manifest
  2. +28 −2 library.scm
  3. +18 −29 scheduler.scm
  4. +2 −2 tests/runtests.sh
View
1 distribution/manifest
@@ -175,6 +175,7 @@ tests/dwindtst.expected
tests/callback-tests.scm
tests/reader-tests.scm
tests/pp-test.scm
+tests/finalizer-error-test.scm
tests/reverser/reverser.meta
tests/reverser/reverser.setup
tests/reverser/reverser.scm
View
30 library.scm
@@ -4497,8 +4497,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) ) )
@@ -4636,6 +4638,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)
View
47 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:
View
4 tests/runtests.sh
@@ -264,8 +264,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

0 comments on commit 70d90bc

Please sign in to comment.
Something went wrong with that request. Please try again.