Fix QUERY-FILE-SYSTEM for Windows UNC and device file names

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

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 0d1febe..5d2d598 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,6 +167,87 @@ 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))
 

+(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
+      (case op
+        (aref
+         (when (cddr args)
+           (invalid-place))
+         #!+(or x86 x86-64 ppc)
+         (with-unique-names (array)
+           `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
+              (%array-atomic-incf/word
+               ,array
+               (%check-bound ,array (array-dimension ,array 0) ,(cadr args))
+               (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))))))))
+         #!-(or x86 x86-64 ppc)
+         (with-unique-names (array index old-value)
+           (let ((incremented-value
+                  (ecase name
+                         (atomic-incf
+                          `(+ ,old-value (the sb!vm:signed-word ,diff)))
+                         (atomic-decf
+                          `(- ,old-value (the sb!vm:signed-word ,diff))))))
+             `(sb!sys:without-interrupts
+               (let* ((,array ,(car args))
+                      (,index ,(cadr args))
+                      (,old-value (aref ,array ,index)))
+                 (setf (aref ,array ,index)
+                       (logand #.(1- (ash 1 sb!vm:n-word-bits))
+                               ,incremented-value))
+                 ,old-value)))))
+        (t
+         (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
 (defmacro atomic-incf (place &optional (diff 1))
   #!+sb-doc
   "Atomically increments PLACE by DIFF, and returns the value of PLACE before

@@ -178,48 +259,42 @@ 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,
 
 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.
+and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
+SB-EXT:WORD (*) -- 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."
 
 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))))))
+  (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 or an AREF of a (SIMPLE-ARRAY
+SB-EXT:WORD (*) -- 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))
+
+;; Interpreter stubs for ATOMIC-INCF.
+#!+(or x86 x86-64 ppc)
+(defun %array-atomic-incf/word (array index diff)
+  (declare (type (simple-array word (*)) array)
+           (fixnum index)
+           (type sb!vm:signed-word diff))
+  (%array-atomic-incf/word array index diff))

 
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)
 
 (defun call-hooks (kind hooks &key (on-error :error))
   (dolist (hook hooks)

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