From 60ce532301c8f4b7ed289d049717ee16639bc4d4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 20 Aug 2006 09:28:22 +0000 Subject: [PATCH] 0.9.15.40: reentrant STABLE-SORT and ADJUST-ARRAY * Create new (initially length 0) temp vectors for each thread. * Rename APPLY-KEYED-PRED to FUNCALL2-USING-KEY. * Update threading-specials list a bit. --- NEWS | 6 +- doc/internals-notes/threading-specials | 10 +-- src/code/array.lisp | 8 +- src/code/sort.lisp | 146 ++++++++++++++++---------------- src/code/target-thread.lisp | 2 + src/runtime/linux-os.c | 4 +- version.lisp-expr | 2 +- 7 files changed, 94 insertions(+), 84 deletions(-) diff --git a/NEWS b/NEWS index c72ccc9..de2eb1f 100644 --- a/NEWS +++ b/NEWS @@ -54,8 +54,10 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: types in some cases. * bug fix: fixed input, output and error redirection in RUN-PROGRAM for win32. (thanks to Mike Thomas and Yaroslav Kavenchuk) - * bug fix: CONDITION-WAIT could return early on Linux, if the thread was - interrupted and subsequently continued with SIGCONT. + * thread-safety improvements: + ** CONDITION-WAIT could return early on Linux, if the thread was + interrupted and subsequently continued with SIGCONT. + ** STABLE-SORT and ADJUST-ARRAY were not reentrant. changes in sbcl-0.9.15 relative to sbcl-0.9.14: * added support for the ucs-2 external format. (contributed by Ivan diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials index d27b248..9b67b2a 100644 --- a/doc/internals-notes/threading-specials +++ b/doc/internals-notes/threading-specials @@ -130,6 +130,7 @@ bound & safe: SB-PCL::*ALLOW-FORWARD-REFERENCED-CLASSES-IN-CPL-P* SB-PCL::*IN-OBSOLETE-INSTANCE-TRAP* SB-PCL::*PRECOMPILING-LAP* + SB-PCL::*CACHE-MISS-VALUES-STACK* believed protected by the compiler-lock: SB-PCL::*ALL-CTORS* @@ -138,7 +139,6 @@ believed protected by the compiler-lock: SB-PCL::*VAR-DECLARATIONS-WITHOUT-ARG* potentially unsafe: - SB-PCL::*CACHE-MISS-VALUES-STACK* SB-PCL::*CLASS-EQ-SPECIALIZER-METHODS* SB-PCL::*EFFECTIVE-METHOD-CACHE* SB-PCL::*EQL-SPECIALIZER-METHODS* @@ -806,7 +806,6 @@ SB-FASL::*CURRENT-FOP-TABLE-SIZE* SB-FASL::*FOP-STACK-POINTER-ON-ENTRY* SB-FASL::*FREE-FOP-TABLES* SB-FASL::*LOAD-SYMBOL-BUFFER* -SB-FASL::*CURRENT-CATCH-BLOCK* SB-FASL::*FASL-HEADER-STRING-START-STRING* SB-FASL::DUMP-FOP* SB-FASL::FOP-LIST* @@ -848,8 +847,7 @@ SB-KERNEL:*NEED-TO-COLLECT-GARBAGE* SB-KERNEL:*ALREADY-MAYBE-GCING* SB-KERNEL:*PSEUDO-ATOMIC-INTERRUPTED* ; bound SB-KERNEL::*GC-TRIGGER* ; I think this is dead, check -SB-IMPL::*CURRENT-UNWIND-PROTECT-BLOCK* -SB-IMPL::*CURRENT-CATCH-BLOCK* +SB-IMPL::*CURRENT-UNWIND-PROTECT-BLOCK* ; thread-local SB-IMPL::*READ-ONLY-SPACE-FREE-POINTER* SB-VM::*ALIEN-STACK* ; bound in create_thread_struct() @@ -1044,7 +1042,7 @@ SB-IMPL::*INTEGER-READER-SAFE-DIGITS* SB-IMPL::*TIMEZONE-TABLE* SB-IMPL::*BQ-COMMA-FLAG* ; readonly SB-IMPL::*PRINT-OBJECT-IS-DISABLED-P* -SB-IMPL::*MERGE-SORT-TEMP-VECTOR* ; FIXME: SORT non-threadsafe, non-reentrant +SB-IMPL::*MERGE-SORT-TEMP-VECTOR* ; safe, allocated per-thread SB-IMPL::*PROFILE-HASH-CACHE* SB-IMPL::*FIXNUM-POWER--1* SB-IMPL::*SHARP-EQUAL-CIRCLE-TABLE* @@ -1057,7 +1055,7 @@ SB-IMPL::*CLOSE-IN-PARENT* SB-IMPL::*IN-COMPILATION-UNIT* SB-IMPL::*CIRCULARITY-HASH-TABLE* SB-IMPL::*LOAD-PRINT-STUFF* -SB-IMPL::*ZAP-ARRAY-DATA-TEMP* ; FIXME: ADJUST-ARRAY non-threadsafe +SB-IMPL::*ZAP-ARRAY-DATA-TEMP* ; safe, allocated per-thread SB-IMPL::*ACTIVE-PROCESSES* SB-IMPL::*SHARP-SHARP-ALIST* SB-IMPL::*BASE-POWER* diff --git a/src/code/array.lisp b/src/code/array.lisp index 29d54a2..a3c6793 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -975,7 +975,13 @@ of specialized arrays is supported." ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ. -;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. +;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound +;;; to length zero array in each new thread. +;;; +;;; DX is probably a bad idea, because a with a big array it would +;;; be fairly easy to blow the stack. +;;; +;;; Rebound per thread. (defvar *zap-array-data-temp* (make-array 1000 :initial-element t)) (defun zap-array-data-temp (length element-type initial-element diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 1c21986..3087025 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -70,9 +70,9 @@ :format-control "~S is not a sequence." :format-arguments (list sequence)))))) -;;; APPLY-KEYED-PRED saves us a function call sometimes. +;;; FUNCALL-USING-KEY saves us a function call sometimes. (eval-when (:compile-toplevel :execute) - (sb!xc:defmacro apply-keyed-pred (one two pred key) + (sb!xc:defmacro funcall2-using-key (pred key one two) `(if ,key (funcall ,pred (funcall ,key ,one) (funcall ,key ,two)) @@ -222,9 +222,9 @@ (incf ,target-i) (incf ,i)) (return)) - ((apply-keyed-pred (,source-ref ,source ,j) - (,source-ref ,source ,i) - ,pred ,key) + ((funcall2-using-key ,pred ,key + (,source-ref ,source ,j) + (,source-ref ,source ,i)) (setf (,target-ref ,target ,target-i) (,source-ref ,source ,j)) (incf ,j)) @@ -238,75 +238,77 @@ ;;; are merging into the temporary (T) or back into the given vector ;;; (NIL). (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref) - (let ((vector-len (gensym)) (n (gensym)) - (direction (gensym)) (unsorted (gensym)) - (start-1 (gensym)) (end-1 (gensym)) - (end-2 (gensym)) (temp-len (gensym)) - (i (gensym))) - `(let ((,vector-len (length (the vector ,vector))) - (,n 1) ; bottom-up size of contiguous runs to be merged - (,direction t) ; t vector --> temp nil temp --> vector - (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) - (,unsorted 0) ; unsorted..vector-len are the elements that need - ; to be merged for a given n - (,start-1 0)) ; one n-len subsequence to be merged with the next - (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)) + (with-unique-names + (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i) + `(let* ((,vector-len (length (the vector ,vector))) + (,n 1) ; bottom-up size of contiguous runs to be merged + (,direction t) ; t vector --> temp nil temp --> vector + (,temp *merge-sort-temp-vector*) + (,temp-len (length ,temp)) + (,unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (,start-1 0)) ; one n-len subsequence to be merged with the next + (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1) + (simple-vector ,temp)) (if (> ,vector-len ,temp-len) - (setf *merge-sort-temp-vector* - (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) - (loop - ;; for each n, we start taking n-runs from the start of the vector - (setf ,unsorted 0) - (loop - (setf ,start-1 ,unsorted) - (let ((,end-1 (+ ,start-1 ,n))) - (declare (fixnum ,end-1)) - (cond ((< ,end-1 ,vector-len) - ;; there are enough elements for a second run - (let ((,end-2 (+ ,end-1 ,n))) - (declare (fixnum ,end-2)) - (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) - (setf ,unsorted ,end-2) - (if ,direction - (stable-sort-merge-vectors* - ,vector *merge-sort-temp-vector* - ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) - (stable-sort-merge-vectors* - *merge-sort-temp-vector* ,vector - ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) - (if (= ,unsorted ,vector-len) (return)))) - ;; if there is only one run, copy those elements to the end - (t (if ,direction - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (svref *merge-sort-temp-vector* ,i) - (,vector-ref ,vector ,i))) - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return))))) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two subsequences given n, so all the elements have - ;; been merged into one list. Start-1 will have remained 0 upon exit. - (when (zerop ,start-1) - (if ,direction - ;; if we just merged into the temporary, copy it all back - ;; to the given vector. - (dotimes (,i ,vector-len) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return ,vector)) - (setf ,n (ash ,n 1)) ; (* 2 n) - (setf ,direction (not ,direction)))))) + (setf ,temp (make-array (max ,vector-len + (min most-positive-fixnum + (+ ,temp-len ,temp-len)))) + *merge-sort-temp-vector* ,temp)) + ;; rebind, in case PRED or KEY calls STABLE-SORT + (let ((*merge-sort-temp-vector* (vector))) + (loop + ;; for each n, we start taking n-runs from the start of the vector + (setf ,unsorted 0) + (loop + (setf ,start-1 ,unsorted) + (let ((,end-1 (+ ,start-1 ,n))) + (declare (fixnum ,end-1)) + (cond ((< ,end-1 ,vector-len) + ;; there are enough elements for a second run + (let ((,end-2 (+ ,end-1 ,n))) + (declare (fixnum ,end-2)) + (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) + (setf ,unsorted ,end-2) + (if ,direction + (stable-sort-merge-vectors* + ,vector ,temp + ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) + (stable-sort-merge-vectors* + ,temp ,vector + ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) + (if (= ,unsorted ,vector-len) (return)))) + ;; if there is only one run, copy those elements to the end + (t (if ,direction + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (svref ,temp ,i) + (,vector-ref ,vector ,i))) + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (,vector-ref ,vector ,i) + (svref ,temp ,i)))) + (return))))) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two subsequences given n, so all the elements have + ;; been merged into one list. Start-1 will have remained 0 upon exit. + (when (zerop ,start-1) + (if ,direction + ;; if we just merged into the temporary, copy it all back + ;; to the given vector. + (dotimes (,i ,vector-len) + (setf (,vector-ref ,vector ,i) + (svref ,temp ,i)))) + (return ,vector)) + (setf ,n (ash ,n 1)) ; (* 2 n) + (setf ,direction (not ,direction))))))) ) ; EVAL-when -;;; temporary vector for stable sorting vectors -(defvar *merge-sort-temp-vector* - (make-array 50)) +;;; temporary vector for stable sorting vectors, allocated for each new thread +(defvar *merge-sort-temp-vector* (make-array 50)) (declaim (simple-vector *merge-sort-temp-vector*)) @@ -353,8 +355,8 @@ (incf ,result-i) (incf ,i)) (return ,result-vector)) - ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) - ,pred ,key) + ((funcall2-using-key ,pred ,key + (,access ,vector-2 ,j) (,access ,vector-1 ,i)) (setf (,access ,result-vector ,result-i) (,access ,vector-2 ,j)) (incf ,j)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 9296ce1..c5b6fcb 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -610,6 +610,8 @@ returns the thread exits." ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) + (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! + (sb!impl::*zap-array-data-temp* (vector)) ; (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event (setf (thread-os-thread thread) (current-thread-sap-id)) diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index b57b300..fbc888e 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -88,13 +88,13 @@ futex_wait(int *lock_word, int oldval) again: t = sys_futex(lock_word,FUTEX_WAIT,oldval, 0); - /* Interrupted FUTEX_WAIT calls may return early. + /* Interrupted FUTEX_WAIT calls may return early. * * If someone manages to wake the futex while we're spinning * around it, we will just return with -1 and errno EWOULDBLOCK, * because the value has changed, so that's ok. */ if (t != 0 && errno == EINTR) - goto again; + goto again; return t; } diff --git a/version.lisp-expr b/version.lisp-expr index 8fbff01..9ac0587 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".) -"0.9.15.39" +"0.9.15.40" -- 1.7.10.4