From: Alastair Bridgewater Date: Thu, 7 Oct 2010 16:35:53 +0000 (+0000) Subject: 1.0.43.30: threads: Initial implementation of ATOMIC-INCF for arrays. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ba3bf8ccc42770b90765cd839c6579e62b495bbb;p=sbcl.git 1.0.43.30: threads: Initial implementation of ATOMIC-INCF for arrays. * Teach SB-IMPL::EXPAND-ATOMIC-FROB to deal with unboxed vectors of words as places. * Define SB-KERNEL:%ARRAY-ATOMIC-INCF/WORD by analogy to SB-KERNEL:%RAW-INSTACE-ATOMIC-INCF/WORD. * Add SB-KERNEL:%ARRAY-ATOMIC-INCF/WORD to the VM fndb. * While we're here, define an interpreter stub for %ARRAY-ATOMIC-INCF/WORD. %RAW-INSTANCE-ATOMIC-INCF/WORD still needs one, but that's out of scope right now. * Note that this is just the arch-independent parts of ATOMIC-INCF for arrays, the per-arch parts will be separate commits. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2e60e4a..78c8b4b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1223,6 +1223,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ARRAY-DISPLACED-FROM" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" + #!+(or) + "%ARRAY-ATOMIC-INCF/WORD" "%ASSOC" "%ASSOC-EQ" "%ASSOC-IF" diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 0062618..77582d0 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -173,47 +173,80 @@ EXPERIMENTAL: Interface subject to change." (unless (consp place) (invalid-place)) (destructuring-bind (op &rest args) place - (when (cdr args) - (invalid-place)) - (let ((dd (info :function :structure-accessor op))) - (if dd - (let* ((structure (dd-name dd)) - (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) - (index (dsd-index slotd)) - (type (dsd-type slotd))) - (declare (ignorable structure index)) - (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) - (type= (specifier-type type) (specifier-type 'sb!vm:word))) - (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" - name sb!vm:n-word-bits type place)) - (when (dsd-read-only slotd) - (error "Cannot use ~S with structure accessor for a read-only slot: ~S" - name place)) - #!+(or x86 x86-64 ppc) - `(truly-the sb!vm:word - (%raw-instance-atomic-incf/word - (the ,structure ,@args) ,index - (logand #.(1- (ash 1 sb!vm:n-word-bits)) - ,(ecase name - (atomic-incf - `(the sb!vm:signed-word ,diff)) - (atomic-decf - `(- (the sb!vm:signed-word ,diff))))))) - ;; No threads outside x86 and x86-64 for now, so this is easy... - #!-(or x86 x86-64 ppc) - (with-unique-names (structure old) - `(sb!sys:without-interrupts - (let* ((,structure ,@args) - (,old (,op ,structure))) - (setf (,op ,structure) - (logand #.(1- (ash 1 sb!vm:n-word-bits)) - ,(ecase name - (atomic-incf - `(+ ,old (the sb!vm:signed-word ,diff))) - (atomic-decf - `(- ,old (the sb!vm:signed-word ,diff)))))) - ,old)))) - (invalid-place)))))) + (case op + (aref + (when (cddr args) + (invalid-place)) + #!+(or) + (with-unique-names (array) + `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args)))) + (%array-atomic-incf/word + ,array + (%check-bound ,array (array-dimension ,array 0) ,(cadr args)) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(the sb!vm:signed-word ,diff)) + (atomic-decf + `(- (the sb!vm:signed-word ,diff)))))))) + #!-(or) + (with-unique-names (array index old-value) + (let ((incremented-value + (ecase name + (atomic-incf + `(+ ,old-value (the sb!vm:signed-word ,diff))) + (atomic-decf + `(- ,old-value (the sb!vm:signed-word ,diff)))))) + `(sb!sys:without-interrupts + (let* ((,array ,(car args)) + (,index ,(cadr args)) + (,old-value (aref ,array ,index))) + (setf (aref ,array ,index) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,incremented-value)) + ,old-value))))) + (t + (when (cdr args) + (invalid-place)) + (let ((dd (info :function :structure-accessor op))) + (if dd + (let* ((structure (dd-name dd)) + (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) + (index (dsd-index slotd)) + (type (dsd-type slotd))) + (declare (ignorable structure index)) + (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) + (type= (specifier-type type) (specifier-type 'sb!vm:word))) + (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + name sb!vm:n-word-bits type place)) + (when (dsd-read-only slotd) + (error "Cannot use ~S with structure accessor for a read-only slot: ~S" + name place)) + #!+(or x86 x86-64 ppc) + `(truly-the sb!vm:word + (%raw-instance-atomic-incf/word + (the ,structure ,@args) ,index + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(the sb!vm:signed-word ,diff)) + (atomic-decf + `(- (the sb!vm:signed-word ,diff))))))) + ;; No threads outside x86 and x86-64 for now, so this is easy... + #!-(or x86 x86-64 ppc) + (with-unique-names (structure old) + `(sb!sys:without-interrupts + (let* ((,structure ,@args) + (,old (,op ,structure))) + (setf (,op ,structure) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(+ ,old (the sb!vm:signed-word ,diff))) + (atomic-decf + `(- ,old (the sb!vm:signed-word ,diff)))))) + ,old)))) + (invalid-place)))))))) (defmacro atomic-incf (place &optional (diff 1)) #!+sb-doc @@ -226,8 +259,8 @@ PLACE. PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, -and (UNSIGNED-BYTE 64) on 64 bit platforms -- the type SB-EXT:WORD can be used -for this purpose. +and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY +SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose. DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, and (SIGNED-BYTE 64) on 64 bit platforms. @@ -246,8 +279,8 @@ PLACE. PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, -and (UNSIGNED-BYTE 64) on 64 bit platforms -- the type SB-EXT:WORD can be used -for this purpose. +and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY +SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose. DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, and (SIGNED-BYTE 64) on 64 bit platforms. @@ -255,6 +288,14 @@ and (SIGNED-BYTE 64) on 64 bit platforms. EXPERIMENTAL: Interface subject to change." (expand-atomic-frob 'atomic-decf place diff)) +;; Interpreter stubs for ATOMIC-INCF. +#!+(or) +(defun %array-atomic-incf/word (array index diff) + (declare (type (simple-array word (*)) array) + (fixnum index) + (type sb!vm:signed-word diff)) + (%array-atomic-incf/word array index diff)) + (defun call-hooks (kind hooks &key (on-error :error)) (dolist (hook hooks) (handler-case diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 8976ed2..dd11795 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -168,6 +168,9 @@ #!+(or x86 x86-64 ppc) (defknown %raw-instance-atomic-incf/word (instance index sb!vm:word) sb!vm:word (unsafe always-translatable)) +#!+(or) +(defknown %array-atomic-incf/word (t index sb!vm:word) sb!vm:word + (unsafe always-translatable)) ;;; These two are mostly used for bit-bashing operations. (defknown %vector-raw-bits (t fixnum) sb!vm:word diff --git a/version.lisp-expr b/version.lisp-expr index c4eb71b..4b56650 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.43.29" +"1.0.43.30"