1.0.42.11: SB-EXT:WORD for use with ATOMIC-INCF &co

[sbcl.git] / src / code / late-extensions.lisp

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 0d1febe..0062618 100644 (file)
--- 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
 (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:
 
 
 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))
                            (,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)))
                        (%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))
 
   (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 ()
   (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
     (unless (consp place)
       (invalid-place))
     (destructuring-bind (op &rest args) place

@@ -200,27 +184,77 @@ 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)))
               (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)
               (when (dsd-read-only slotd)

-                (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S"
-                       place))
-              #!+(or x86 x86-64)
+                (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
               `(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...
               ;; No threads outside x86 and x86-64 for now, so this is easy...

-              #!-(or x86 x86-64)
+              #!-(or x86 x86-64 ppc)

               (with-unique-names (structure old)
                 `(sb!sys:without-interrupts
                    (let* ((,structure ,@args)
                           (,old (,op ,structure)))
               (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))))))
 
                      ,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
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)
     (handler-case

@@ -230,3 +264,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)))))))
             (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)