From 6e953f60d904a015b3273db84b5886b04a9ecb1c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 15 Jun 2007 16:53:43 +0000 Subject: [PATCH] 1.0.6.47: small fixes * When expanding the CLOS cache, insert the new value before copying the old ones, in order to ensure that FILL-CACHE always terminations. * Cancel deadline before signalling the DEADLINE-ERROR, so that same deadline cannot be caught again during unwind. --- src/code/deadline.lisp | 5 +++++ src/pcl/cache.lisp | 9 +++++++-- version.lisp-expr | 2 +- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 757e4d9..4ea6e72 100644 --- a/src/code/deadline.lisp +++ b/src/code/deadline.lisp @@ -65,6 +65,7 @@ deadlines while the condition is being handled." ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.) (with-interrupts + ;; Don't signal a deadline while handling a non-deadline timeout. (let ((*deadline* nil)) (apply #'error datum arguments)))) @@ -72,6 +73,10 @@ deadlines while the condition is being handled." #!+sb-doc "Signal a DEADLINE-TIMEOUT condition. Implementors of blocking functions are responsible for calling this when a deadline is reached." + ;; Make sure we don't signal the same deadline twice. LET is not good + ;; enough: we might catch the same deadline again while unwinding. + (when *deadline* + (setf *deadline* nil)) (signal-timeout 'deadline-timeout :seconds *deadline-seconds*)) ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index d6afcc0..b4d3e9d 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -337,7 +337,7 @@ ;;;; Copies and expands the cache, dropping any invalidated or ;;;; incomplete lines. -(defun copy-and-expand-cache (cache) +(defun copy-and-expand-cache (cache layouts value) (let ((copy (%copy-cache cache)) (length (length (cache-vector cache)))) (when (< length +cache-vector-max-length+) @@ -351,6 +351,11 @@ (cache-depth copy) 0 (cache-mask copy) (compute-cache-mask length (cache-line-size cache)) (cache-limit copy) (compute-limit (/ length (cache-line-size cache)))) + ;; First insert the new one -- if we don't do this first and + ;; the cache has reached it's maximum size we may end up + ;; looping in FILL-CACHE. + (unless (try-update-cache copy layouts value) + (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value cache)) (map-cache (lambda (layouts value) (unless (try-update-cache copy layouts value) ;; If the cache would grow too much we drop the @@ -413,7 +418,7 @@ ;; we just drop the invalid entries. (%fill-cache (copy-cache cache) layouts value)) (t - (%fill-cache (copy-and-expand-cache cache) layouts value))))) + (copy-and-expand-cache cache layouts value))))) (if (listp layouts) (%fill-cache cache layouts value) (%fill-cache cache (list layouts) value)))) diff --git a/version.lisp-expr b/version.lisp-expr index a6682f8..57aad90 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.6.46" +"1.0.6.47" -- 1.7.10.4