Declare types for sb-kernel:coerce-to-condition.

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

diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp
index aca1cc5..b0aeb17 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,15 +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
-        (let* ((*interrupts-enabled* nil)
-               (*gc-inhibit* t))
-          ,@body)
-     (when (or (and *interrupts-enabled* *interrupt-pending*)
-               (and (not *gc-inhibit*)
-                    (or *gc-pending* #!+sb-thread *stop-for-gc-pending*)))
-       (sb!unix::receive-pending-interrupt))))
-
+  (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)

@@ -151,51 +165,58 @@ 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...
 
 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
 ;;; method. The stream is assumed to be a ANSI-STREAM.
 ;;;
 
 ;;;; And these for the fasloader...
 
 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
 ;;; method. The stream is assumed to be a ANSI-STREAM.
 ;;;

-;;; KLUDGE: It seems weird to have to remember to explicitly call
-;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
-;;; already wrapping the stuff inside in a block. Why not rename this
-;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
-;;; automatically at the end of the block, and eliminate
-;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
-;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
-(defmacro prepare-for-fast-read-byte (stream &body forms)
-  `(let* ((%frc-stream% ,stream)
-          (%frc-method% (ansi-stream-bin %frc-stream%))
-          (%frc-buffer% (ansi-stream-in-buffer %frc-stream%))
-          (%frc-index% (ansi-stream-in-index %frc-stream%)))
-     (declare (type index %frc-index%)
-              (type ansi-stream %frc-stream%))
-     ,@forms))
-
-;;; Similar to fast-read-char, but we use a different refill routine & don't
-;;; convert to characters. If ANY-TYPE is true, then this can be used on any
-;;; integer streams, and we don't assert the result type.
-(defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
-  ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
-  `(truly-the
-    ,(if (and (eq eof-error-p t) (not any-type)) '(unsigned-byte 8) t)
-    (cond
-     ((not %frc-buffer%)
-      (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
-     ((= %frc-index% +ansi-stream-in-buffer-length+)
-      (prog1 (fast-read-byte-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%))))))
-(defmacro done-with-fast-read-byte ()
-  `(done-with-fast-read-char))
+;;; FIXME: Refactor PREPARE-FOR-FAST-READ-CHAR into similar shape.
+(defmacro with-fast-read-byte ((type stream &optional (eof-error-p t) eof-value)
+                               &body body)
+  (aver (or (eq t eof-error-p) (eq t type)))
+  (with-unique-names (f-stream f-method f-buffer f-index eof-p eof-val)
+    `(let* ((,f-stream ,stream)
+            (,eof-p ,eof-error-p)
+            (,eof-val ,eof-value)
+            (,f-method (ansi-stream-bin ,f-stream))
+            (,f-buffer (ansi-stream-in-buffer ,f-stream))
+            (,f-index (ansi-stream-in-index ,f-stream)))
+       (declare (type ansi-stream ,f-stream)
+                (type index ,f-index))
+       (declare (disable-package-locks fast-read-byte))
+       (flet ((fast-read-byte ()
+                  (,@(cond ((equal '(unsigned-byte 8) type)
+                            ;; KLUDGE: For some reason I haven't tracked down
+                            ;; this makes a difference even in given the TRULY-THE.
+                            `(logand #xff))
+                           (t
+                            `(identity)))
+                   (truly-the ,type
+                              (cond
+                                ((not ,f-buffer)
+                                 (funcall ,f-method ,f-stream ,eof-p ,eof-val))
+                                ((= ,f-index +ansi-stream-in-buffer-length+)
+                                 (prog1 (fast-read-byte-refill ,f-stream ,eof-p ,eof-val)
+                                   (setq ,f-index (ansi-stream-in-index ,f-stream))))
+                                (t
+                                 (prog1 (aref ,f-buffer ,f-index)
+                                   (incf ,f-index))))))))
+         (declare (inline fast-read-byte))
+         (declare (enable-package-locks read-byte))
+         (unwind-protect
+              (locally ,@body)
+           (setf (ansi-stream-in-index ,f-stream) ,f-index))))))