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

[sbcl.git] / src / code / sysmacs.lisp

diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp
index 3556bc1..59b8b45 100644 (file)
--- a/src/code/sysmacs.lisp
+++ b/src/code/sysmacs.lisp
@@ -11,24 +11,26 @@
 
 (in-package "SB!IMPL")
 
 
 (in-package "SB!IMPL")
 

-(defmacro atomic-incf/symbol (symbol-name &optional (delta 1))
-  #!-sb-thread
-  `(incf ,symbol-name ,delta)
-  #!+sb-thread
-  `(locally
-    (declare (optimize (safety 0) (speed 3)))
-    (sb!vm::locked-symbol-global-value-add ',symbol-name ,delta)))
+;;;; these are initialized in cold init

 
 

-(defvar *gc-inhibit*) ; initialized in cold init
+(defvar *in-without-gcing*)
+(defvar *gc-inhibit*)

 
 ;;; When the dynamic usage increases beyond this amount, the system
 ;;; notes that a garbage collection needs to occur by setting
 ;;; *GC-PENDING* to T. It starts out as NIL meaning nobody has figured
 ;;; out what it should be yet.
 
 ;;; When the dynamic usage increases beyond this amount, the system
 ;;; notes that a garbage collection needs to occur by setting
 ;;; *GC-PENDING* to T. It starts out as NIL meaning nobody has figured
 ;;; out what it should be yet.

-(defvar *gc-pending* nil)
+(defvar *gc-pending*)

 
 #!+sb-thread
 
 #!+sb-thread

-(defvar *stop-for-gc-pending* nil)
+(defvar *stop-for-gc-pending*)
+
+;;; This one is initialized by the runtime, at thread creation.  On
+;;; non-x86oid gencgc targets, this is a per-thread list of objects
+;;; which must not be moved during GC.  It is frobbed by the code for
+;;; with-pinned-objects in src/compiler/target/macros.lisp.
+#!+(and gencgc (not (or x86 x86-64)))
+(defvar sb!vm::*pinned-objects*)

 
 (defmacro without-gcing (&body body)
   #!+sb-doc
 
 (defmacro without-gcing (&body body)
   #!+sb-doc

@@ -48,13 +50,27 @@ stopped for GC while T2 is waiting for the lock inside WITHOUT-GCING the
 system will be deadlocked. Since SBCL does not currently document its internal
 locks, application code can never be certain that this invariant is
 maintained."
 system will be deadlocked. Since SBCL does not currently document its internal
 locks, application code can never be certain that this invariant is
 maintained."

-  `(unwind-protect
-        (without-interrupts
-          (let ((*gc-inhibit* t))
-            ,@body))
-     ;; the test is racy, but it can err only on the overeager side
-     (sb!kernel::maybe-handle-pending-gc)))
-
+  (with-unique-names (without-gcing-body)
+    `(dx-flet ((,without-gcing-body ()
+              ,@body))
+       (if *gc-inhibit*
+           (,without-gcing-body)
+           ;; We need to disable interrupts before disabling GC, so
+           ;; that signal handlers using locks don't accidentally try
+           ;; to grab them with GC inhibited.
+           (let ((*in-without-gcing* t))
+             (unwind-protect
+                  (let* ((*allow-with-interrupts* nil)
+                         (*interrupts-enabled* nil)
+                         (*gc-inhibit* t))
+                    (,without-gcing-body))
+               ;; This is not racy becuase maybe_defer_handler
+               ;; defers signals if *GC-INHIBIT* is NIL but there
+               ;; is a pending gc or stop-for-gc.
+               (when (or *interrupt-pending*
+                         *gc-pending*
+                         #!+sb-thread *stop-for-gc-pending*)
+                 (sb!unix::receive-pending-interrupt))))))))

 \f
 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
 (defmacro eof-or-lose (stream eof-error-p eof-value)
 \f
 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
 (defmacro eof-or-lose (stream eof-error-p eof-value)

@@ -149,14 +165,19 @@ maintained."
 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR.
 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
   `(cond
 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR.
 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
   `(cond

-    ((not %frc-buffer%)
-     (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
-    ((= %frc-index% +ansi-stream-in-buffer-length+)
-     (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
-            (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
-    (t
-     (prog1 (aref %frc-buffer% %frc-index%)
-            (incf %frc-index%)))))
+     ((not %frc-buffer%)
+      (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
+     ((= %frc-index% +ansi-stream-in-buffer-length+)
+      (multiple-value-bind (eof-p index-or-value)
+          (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
+        (if eof-p
+            index-or-value
+            (progn
+              (setq %frc-index% (1+ index-or-value))
+              (aref %frc-buffer% index-or-value)))))
+     (t
+      (prog1 (aref %frc-buffer% %frc-index%)
+        (incf %frc-index%)))))

 
 ;;;; And these for the fasloader...
 
 
 ;;;; And these for the fasloader...