src/code/sysmacs.lisp

   1 ;;;; miscellaneous system hacking macros
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defmacro atomic-incf/symbol (symbol-name &optional (delta 1))
  15   #!-sb-thread
  16   `(incf ,symbol-name ,delta)
  17   #!+sb-thread
  18   `(locally
  19     (declare (optimize (safety 0) (speed 3)))
  20     (sb!vm::locked-symbol-global-value-add ',symbol-name ,delta)))
  21
  22 (defvar *gc-inhibit*) ; initialized in cold init
  23
  24 ;;; When the dynamic usage increases beyond this amount, the system
  25 ;;; notes that a garbage collection needs to occur by setting
  26 ;;; *GC-PENDING* to T. It starts out as NIL meaning nobody has figured
  27 ;;; out what it should be yet.
  28 (defvar *gc-pending* nil)
  29
  30 #!+sb-thread
  31 (defvar *stop-for-gc-pending* nil)
  32
  33 (defmacro without-gcing (&body body)
  34   #!+sb-doc
  35   "Executes the forms in the body without doing a garbage collection. It
  36 inhibits both automatically and explicitly triggered collections. Finally,
  37 upon leaving the BODY if gc is not inhibited it runs the pending gc.
  38 Similarly, if gc is triggered in another thread then it waits until gc is
  39 enabled in this thread.
  40
  41 Implies SB-SYS:WITHOUT-INTERRUPTS for BODY, and causes any nested
  42 SB-SYS:WITH-INTERRUPTS to signal a warning during execution of the BODY.
  43
  44 Should be used with great care, and not at all in multithreaded application
  45 code: Any locks that are ever acquired while GC is inhibited need to be always
  46 held with GC inhibited to prevent deadlocks: if T1 holds the lock and is
  47 stopped for GC while T2 is waiting for the lock inside WITHOUT-GCING the
  48 system will be deadlocked. Since SBCL does not currently document its internal
  49 locks, application code can never be certain that this invariant is
  50 maintained."
  51   (with-unique-names (without-gcing-body)
  52     `(flet ((,without-gcing-body ()
  53               ,@body))
  54        (if *gc-inhibit*
  55            (,without-gcing-body)
  56            (without-interrupts
  57              ;; We need to disable interrupts before disabling GC, so that
  58              ;; signal handlers using locks don't accidentally try to grab
  59              ;; them with GC inhibited.
  60              ;;
  61              ;; It would be nice to implement this with just a single UWP, but
  62              ;; unfortunately it seems that it cannot be done: the naive
  63              ;; solution of binding both *INTERRUPTS-ENABLED* and
  64              ;; *GC-INHIBIT*, and checking for both pending GC and interrupts
  65              ;; in the cleanup breaks if we have a GC pending, but no
  66              ;; interrupts, and we receive an asynch unwind while checking for
  67              ;; the pending GC: we unwind before handling the pending GC, and
  68              ;; will be left running with further GCs blocked due to the GC
  69              ;; pending flag.
  70              (unwind-protect
  71                   (let ((*gc-inhibit* t))
  72                     (,without-gcing-body))
  73                (when (or *gc-pending* #!+sb-thread *stop-for-gc-pending*)
  74                  (sb!unix::receive-pending-interrupt))))))))
  75 \f
  76 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
  77 (defmacro eof-or-lose (stream eof-error-p eof-value)
  78   `(if ,eof-error-p
  79        (error 'end-of-file :stream ,stream)
  80        ,eof-value))
  81
  82 ;;; These macros handle the special cases of T and NIL for input and
  83 ;;; output streams.
  84 ;;;
  85 ;;; FIXME: Shouldn't these be functions instead of macros?
  86 (defmacro in-synonym-of (stream &optional check-type)
  87   (let ((svar (gensym)))
  88     `(let ((,svar ,stream))
  89        (cond ((null ,svar) *standard-input*)
  90              ((eq ,svar t) *terminal-io*)
  91              (t ,@(when check-type `((enforce-type ,svar ,check-type))) ;
  92                 #!+high-security
  93                 (unless (input-stream-p ,svar)
  94                   (error 'simple-type-error
  95                          :datum ,svar
  96                          :expected-type '(satisfies input-stream-p)
  97                          :format-control "~S isn't an input stream"
  98                          :format-arguments (list ,svar)))
  99                 ,svar)))))
 100 (defmacro out-synonym-of (stream &optional check-type)
 101   (let ((svar (gensym)))
 102     `(let ((,svar ,stream))
 103        (cond ((null ,svar) *standard-output*)
 104              ((eq ,svar t) *terminal-io*)
 105              (t ,@(when check-type `((check-type ,svar ,check-type)))
 106                 #!+high-security
 107                 (unless (output-stream-p ,svar)
 108                   (error 'simple-type-error
 109                          :datum ,svar
 110                          :expected-type '(satisfies output-stream-p)
 111                          :format-control "~S isn't an output stream."
 112                          :format-arguments (list ,svar)))
 113                 ,svar)))))
 114
 115 ;;; WITH-mumble-STREAM calls the function in the given SLOT of the
 116 ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the
 117 ;;; ARGS for FUNDAMENTAL-STREAMs.
 118 (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
 119   `(let ((stream (in-synonym-of ,stream)))
 120     ,(if stream-dispatch
 121          `(if (ansi-stream-p stream)
 122               (funcall (,slot stream) stream ,@args)
 123               ,@(when stream-dispatch
 124                   `(,(destructuring-bind (function &rest args) stream-dispatch
 125                        `(,function stream ,@args)))))
 126          `(funcall (,slot stream) stream ,@args))))
 127
 128 (defmacro with-out-stream/no-synonym (stream (slot &rest args) &optional stream-dispatch)
 129   `(let ((stream ,stream))
 130     ,(if stream-dispatch
 131          `(if (ansi-stream-p stream)
 132               (funcall (,slot stream) stream ,@args)
 133               ,@(when stream-dispatch
 134                   `(,(destructuring-bind (function &rest args) stream-dispatch
 135                                          `(,function stream ,@args)))))
 136          `(funcall (,slot stream) stream ,@args))))
 137
 138 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
 139   `(with-out-stream/no-synonym (out-synonym-of ,stream)
 140     (,slot ,@args) ,stream-dispatch))
 141
 142 \f
 143 ;;;; These are hacks to make the reader win.
 144
 145 ;;; This macro sets up some local vars for use by the
 146 ;;; FAST-READ-CHAR macro within the enclosed lexical scope. The stream
 147 ;;; is assumed to be a ANSI-STREAM.
 148 ;;;
 149 ;;; KLUDGE: Some functions (e.g. ANSI-STREAM-READ-LINE) use these variables
 150 ;;; directly, instead of indirecting through FAST-READ-CHAR.
 151 (defmacro prepare-for-fast-read-char (stream &body forms)
 152   `(let* ((%frc-stream% ,stream)
 153           (%frc-method% (ansi-stream-in %frc-stream%))
 154           (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%))
 155           (%frc-index% (ansi-stream-in-index %frc-stream%)))
 156      (declare (type index %frc-index%)
 157               (type ansi-stream %frc-stream%))
 158      ,@forms))
 159
 160 ;;; This macro must be called after one is done with FAST-READ-CHAR
 161 ;;; inside its scope to decache the ANSI-STREAM-IN-INDEX.
 162 (defmacro done-with-fast-read-char ()
 163   `(setf (ansi-stream-in-index %frc-stream%) %frc-index%))
 164
 165 ;;; a macro with the same calling convention as READ-CHAR, to be used
 166 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR.
 167 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
 168   `(cond
 169      ((not %frc-buffer%)
 170       (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 171      ((= %frc-index% +ansi-stream-in-buffer-length+)
 172       (multiple-value-bind (eof-p index-or-value)
 173           (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
 174         (if eof-p
 175             index-or-value
 176             (progn
 177               (setq %frc-index% (1+ index-or-value))
 178               (aref %frc-buffer% index-or-value)))))
 179      (t
 180       (prog1 (aref %frc-buffer% %frc-index%)
 181         (incf %frc-index%)))))
 182
 183 ;;;; And these for the fasloader...
 184
 185 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
 186 ;;; method. The stream is assumed to be a ANSI-STREAM.
 187 ;;;
 188 ;;; KLUDGE: It seems weird to have to remember to explicitly call
 189 ;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
 190 ;;; already wrapping the stuff inside in a block. Why not rename this
 191 ;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
 192 ;;; automatically at the end of the block, and eliminate
 193 ;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
 194 ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
 195 (defmacro prepare-for-fast-read-byte (stream &body forms)
 196   `(let* ((%frc-stream% ,stream)
 197           (%frc-method% (ansi-stream-bin %frc-stream%))
 198           (%frc-buffer% (ansi-stream-in-buffer %frc-stream%))
 199           (%frc-index% (ansi-stream-in-index %frc-stream%)))
 200      (declare (type index %frc-index%)
 201               (type ansi-stream %frc-stream%))
 202      ,@forms))
 203
 204 ;;; Similar to fast-read-char, but we use a different refill routine & don't
 205 ;;; convert to characters. If ANY-TYPE is true, then this can be used on any
 206 ;;; integer streams, and we don't assert the result type.
 207 (defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
 208   ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
 209   `(truly-the
 210     ,(if (and (eq eof-error-p t) (not any-type)) '(unsigned-byte 8) t)
 211     (cond
 212      ((not %frc-buffer%)
 213       (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
 214      ((= %frc-index% +ansi-stream-in-buffer-length+)
 215       (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
 216         (setq %frc-index% (ansi-stream-in-index %frc-stream%))))
 217      (t
 218       (prog1 (aref %frc-buffer% %frc-index%)
 219         (incf %frc-index%))))))
 220 (defmacro done-with-fast-read-byte ()
 221   `(done-with-fast-read-char))