;;; Used internally, but it would be nice to provide something
;;; like this for users as well.
-
+;;;
+;;; FIXME / IMPORTANT: If the slot is raw, the address is correct only for
+;;; instances of the specified class, not its subclasses!
#!+sb-thread
(defmacro define-structure-slot-addressor (name &key structure slot)
(let* ((dd (find-defstruct-description structure t))
(slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
- (index (when slotd (dsd-index slotd))))
+ (index (when slotd (dsd-index slotd)))
+ (raw-type (dsd-raw-type slotd)))
(unless index
(error "Slot ~S not found in ~S." slot structure))
`(progn
(sb!ext:truly-the
sb!vm:word
(+ (sb!kernel:get-lisp-obj-address instance)
- (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
+ (- (* ,(if (eq t raw-type)
+ (+ sb!vm:instance-slots-offset index)
+ (- (1+ (sb!kernel::dd-instance-length dd)) sb!vm:instance-slots-offset index
+ (1- (sb!kernel::raw-slot-words raw-type))))
+ sb!vm:n-word-bytes)
sb!vm:instance-pointer-lowtag)))))))
-(defmacro compare-and-swap (place old new)
+(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:
((cdr rest)
`(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
(symbol-plist
- `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
+ `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
(symbol-value
- `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
+ (destructuring-bind (name) args
+ (flet ((slow (symbol)
+ (with-unique-names (n-symbol n-old n-new)
+ `(let ((,n-symbol ,symbol)
+ (,n-old ,old)
+ (,n-new ,new))
+ (declare (symbol ,n-symbol))
+ (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)))
+ (if (eq :special (info :variable :kind cname))
+ ;; Since we know the symbol is a special, we can just generate
+ ;; the type check.
+ `(%compare-and-swap-symbol-value
+ ',cname ,old (the ,(info :variable :type cname) ,new))
+ (slow (list 'quote cname))))
+ (slow name)))))
(svref
(let ((vector (car args))
(index (cadr args)))
(def %compare-and-swap-symbol-value (symbol) symbol-value)
(def %compare-and-swap-svref (vector index) svref))
+(defun expand-atomic-frob (name place diff)
+ (flet ((invalid-place ()
+ (error "Invalid first argument to ~S: ~S" name place)))
+ (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))))))
+
+(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 -- 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.
+
+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 -- 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.
+
+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
(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)
projects / sbcl.git / blobdiff