X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-extensions.lisp;h=3c992d0759769597e43d883eb6ede6e3585841e8;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=0d1febeece52465f2adcd48d7aa31621bf006a41;hpb=cccc20daac3d6d4e1086f387055aa0b6ff8f47d1;p=sbcl.git diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 0d1febe..3c992d0 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -76,7 +76,7 @@ (defmacro compare-and-swap (place old new &environment env) "Atomically stores NEW in PLACE if OLD matches the current value of PLACE. Two values are considered to match if they are EQ. Returns the previous value -of PLACE: if the returned value if EQ to OLD, the swap was carried out. +of PLACE: if the returned value is EQ to OLD, the swap was carried out. PLACE must be an accessor form whose CAR is one of the following: @@ -108,7 +108,7 @@ EXPERIMENTAL: Interface subject to change." (,n-old ,old) (,n-new ,new)) (declare (symbol ,n-symbol)) - (about-to-modify-symbol-value ,n-symbol "compare-and-swap SYMBOL-VALUE of ~S" ,n-new) + (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new) (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new))))) (if (sb!xc:constantp name env) (let ((cname (constant-form-value name env))) @@ -167,25 +167,9 @@ 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)) - #!+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." +(defun expand-atomic-frob (name place diff) (flet ((invalid-place () - (error "Invalid first argument to ATOMIC-INCF: ~S" place))) + (error "Invalid first argument to ~S: ~S" name place))) (unless (consp place) (invalid-place)) (destructuring-bind (op &rest args) place @@ -200,27 +184,75 @@ EXPERIMENTAL: Interface subject to change." (declare (ignorable structure 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)) + (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 ATOMIC-INCF with structure accessor for a read-only slot: ~S" - place)) + (error "Cannot use ~S with structure accessor for a read-only slot: ~S" + name 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))) + (%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) (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)))) + (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 + "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." + (expand-atomic-frob 'atomic-incf place diff)) + +(defmacro atomic-decf (place &optional (diff 1)) + #!+sb-doc + "Atomically decrements PLACE by DIFF, and returns the value of PLACE before +the increment. + +The decrementation is done using word-size modular arithmetic: on 32 bit +platforms ATOMIC-DECF of #x0 by one results in #xFFFFFFFF 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." + (expand-atomic-frob 'atomic-decf place diff)) + (defun call-hooks (kind hooks &key (on-error :error)) (dolist (hook hooks) (handler-case @@ -230,3 +262,42 @@ EXPERIMENTAL: Interface subject to change." (warn "Problem running ~A hook ~S:~% ~A" kind hook c) (with-simple-restart (continue "Skip this ~A hook." kind) (error "Problem running ~A hook ~S:~% ~A" kind hook c))))))) + +;;;; DEFGLOBAL + +(defmacro-mundanely defglobal (name value &optional (doc nil docp)) + #!+sb-doc + "Defines NAME as a global variable that is always bound. VALUE is evaluated +and assigned to NAME both at compile- and load-time, but only if NAME is not +already bound. + +Global variables share their values between all threads, and cannot be +locally bound, declared special, defined as constants, and neither bound +nor defined as symbol macros. + +See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND." + `(progn + (eval-when (:compile-toplevel) + (let ((boundp (boundp ',name))) + (%compiler-defglobal ',name (unless boundp ,value) boundp))) + (eval-when (:load-toplevel :execute) + (let ((boundp (boundp ',name))) + (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp + (sb!c:source-location)))))) + +(defun %compiler-defglobal (name value boundp) + (sb!xc:proclaim `(global ,name)) + (unless boundp + #-sb-xc-host + (set-symbol-global-value name value) + #+sb-xc-host + (set name value)) + (sb!xc:proclaim `(always-bound ,name))) + +(defun %defglobal (name value boundp doc docp source-location) + (%compiler-defglobal name value boundp) + (when docp + (setf (fdocumentation name 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable name) source-location)) + name)