Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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...
commit 70d90bcf689b294a7e02696f210a7e85ed555f99 1 parent a77ae51
@bunny351 bunny351 authored committed
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
Please sign in to comment.
Something went wrong with that request. Please try again.