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