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