;;; 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.
((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))
+(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."
+ (flet ((invalid-place ()
+ (error "Invalid first argument to ATOMIC-INCF: ~S" 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 "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
(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