From 880a863592743d82835e0fb4395301d6ab1f5127 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 17 Sep 2008 22:31:57 +0000 Subject: [PATCH] 1.0.20.8: ATOMIC-INCF implementation * Modular arithmetic on word-sized unsigned structure slots. * Uses XADD on x86 and x86-64, a simple lisp-level implementation elsewhere. --- NEWS | 2 ++ package-data-list.lisp-expr | 3 ++ src/code/late-extensions.lisp | 55 ++++++++++++++++++++++++++++++++++++ src/compiler/generic/vm-fndb.lisp | 7 +++-- src/compiler/x86-64/cell.lisp | 21 ++++++++++++++ src/compiler/x86/cell.lisp | 21 ++++++++++++++ tests/compare-and-swap.impure.lisp | 33 ++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 141 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 6b585e8..86ccfc0 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,6 @@ ;;;; -*- coding: utf-8; -*- + * new feature: SB-EXT:ATOMIC-INCF allows atomic incrementation of + appropriately typed structure slots without locking. * enhancement: reduced conservativism on GENCGC platforms: on average 45% less pages pinned (measured from SBCL self build). * bug fix: SB-EXT:COMPARE-AND-SWAP on SYMBOL-VALUE can no longer diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3329b3c..9eeecf7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -576,6 +576,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "POSIX-GETENV" "POSIX-ENVIRON" "COMPARE-AND-SWAP" + "ATOMIC-INCF" ;; People have various good reasons to mess with the GC. "*AFTER-GC-HOOKS*" @@ -1266,6 +1267,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%RAW-SET-COMPLEX-DOUBLE" "%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE" "%SCALB" "%SCALBN" + #!+(or x86 x86-64) + "%RAW-INSTANCE-ATOMIC-INCF/WORD" "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD" "%RAW-INSTANCE-REF/SINGLE" "%RAW-INSTANCE-SET/SINGLE" "%RAW-INSTANCE-REF/DOUBLE" "%RAW-INSTANCE-SET/DOUBLE" diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 5b0fbaa..2e0a9df 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -160,6 +160,61 @@ EXPERIMENTAL: Interface subject to change." (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) +(defmacro atomic-incf (place &optional (diff 1) &environment env) + #!+sb-doc + "Atomically increments PLACE by DIFF, and returns the value of PLACE before +the increment. + +The incrementation is done using word-size modular arithmetic: on 32 bit +platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in +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. + +DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, +and (SIGNED-BYTE 64) on 64 bit platforms. + +EXPERIMENTAL: Interface subject to change." + (flet ((invalid-place () + (error "Invalid first argument to ATOMIC-INCF: ~S" place))) + (let ((place (macroexpand place env))) + (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 index)) + (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) + (type= (specifier-type type) (specifier-type 'sb!vm:word))) + (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + sb!vm:n-word-bits type place)) + (when (dsd-read-only slotd) + (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S" + place)) + #!+(or x86 x86-64) + `(truly-the sb!vm:word + (%raw-instance-atomic-incf/word (the ,structure ,@args) + ,index + (the sb!vm:signed-word ,diff))) + ;; No threads outside x86 and x86-64 for now, so this is easy... + #!-(or x86 x86-64) + (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)) + (+ ,old (the sb!vm:signed-word ,diff)))) + ,old)))) + (invalid-place))))))) + (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 bd96d7b..28b263b 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -153,8 +153,11 @@ (defknown %raw-instance-set/complex-double (instance index (complex double-float)) (complex double-float) - (unsafe always-translatable)) -) + (unsafe always-translatable))) + +#!+(or x86 x86-64) +(defknown %raw-instance-atomic-incf/word (instance index sb!vm:signed-word) sb!vm:word + (unsafe always-translatable)) ;;; %RAW-{REF,SET}-FOO VOPs should be declared as taking a RAW-VECTOR ;;; as their first argument (clarity and to match these DEFKNOWNs). diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 5a4b846..501bb4d 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -624,6 +624,27 @@ (:generator 4 (inst mov (make-ea-for-raw-slot object index instance-length) value))) +(define-vop (raw-instance-atomic-incf-c/word) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (diff :scs (signed-reg) :target result)) + (:arg-types * (:constant (load/store-index #.n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + signed-num) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + #!+sb-thread + (inst lock) + (inst xadd (make-ea-for-raw-slot object index tmp) diff) + (move result diff))) + (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 168cad8..753838a 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -573,6 +573,27 @@ (:generator 5 (inst mov (make-ea-for-raw-slot object index instance-length 1) value))) +(define-vop (raw-instance-atomic-incf/word) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (diff :scs (signed-reg) :target result)) + (:arg-types * tagged-num signed-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + #!+sb-thread + (inst lock) + (inst xadd (make-ea-for-raw-slot object index tmp 1) diff) + (move result diff))) + (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index 8a034ad..e35b56d 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -104,3 +104,36 @@ (handler-case (sb-ext:compare-and-swap (symbol-value name) t 42) (error () :error))))) + +;;;; ATOMIC-INCF (we should probably rename this file atomic-ops...) + +(defstruct box + (word 0 :type sb-vm:word)) + +(defun inc-box (box n) + (declare (fixnum n) (box box)) + (loop repeat n + do (sb-ext:atomic-incf (box-word box)))) + +(defun dec-box (box n) + (declare (fixnum n) (box box)) + (loop repeat n + do (sb-ext:atomic-incf (box-word box) -1))) + +(let ((box (make-box))) + (inc-box box 10000) + (assert (= 10000 (box-word box))) + (dec-box box 10000) + (assert (= 0 (box-word box)))) + +#+sb-thread +(let* ((box (make-box)) + (threads (loop repeat 64 + collect (sb-thread:make-thread (lambda () + (inc-box box 1000) + (dec-box box 10000) + (inc-box box 10000) + (dec-box box 1000)) + :name "inc/dec thread")))) + (mapc #'sb-thread:join-thread threads) + (assert (= 0 (box-word box)))) diff --git a/version.lisp-expr b/version.lisp-expr index 7324dbc..3ab0ae5 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.20.7" +"1.0.20.8" -- 1.7.10.4