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* nil)
  17 (!defvar *gc-inhibit* t)
  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* nil)
  24
  25 #!+sb-thread
  26 (!defvar *stop-for-gc-pending* nil)
  27
  28 (eval-when (:compile-toplevel :load-toplevel :execute)
  29   (dolist (symbol '(*gc-inhibit* *in-without-gcing*
  30                     *gc-pending* *stop-for-gc-pending*))
  31     (setf (info :variable :always-bound symbol) :always-bound)))
  32
  33 ;;; This one is initialized by the runtime, at thread creation.  On
  34 ;;; non-x86oid gencgc targets, this is a per-thread list of objects
  35 ;;; which must not be moved during GC.  It is frobbed by the code for
  36 ;;; with-pinned-objects in src/compiler/target/macros.lisp.
  37 #!+(and gencgc (not (or x86 x86-64)))
  38 (defvar sb!vm::*pinned-objects*)
  39
  40 (defmacro without-gcing (&body body)
  41   #!+sb-doc
  42   "Executes the forms in the body without doing a garbage collection. It
  43 inhibits both automatically and explicitly triggered collections. Finally,
  44 upon leaving the BODY if gc is not inhibited it runs the pending gc.
  45 Similarly, if gc is triggered in another thread then it waits until gc is
  46 enabled in this thread.
  47
  48 Implies SB-SYS:WITHOUT-INTERRUPTS for BODY, and causes any nested
  49 SB-SYS:WITH-INTERRUPTS to signal a warning during execution of the BODY.
  50
  51 Should be used with great care, and not at all in multithreaded application
  52 code: Any locks that are ever acquired while GC is inhibited need to be always
  53 held with GC inhibited to prevent deadlocks: if T1 holds the lock and is
  54 stopped for GC while T2 is waiting for the lock inside WITHOUT-GCING the
  55 system will be deadlocked. Since SBCL does not currently document its internal
  56 locks, application code can never be certain that this invariant is
  57 maintained."
  58   (with-unique-names (without-gcing-body)
  59     `(dx-flet ((,without-gcing-body ()
  60               ,@body))
  61        (if *gc-inhibit*
  62            (,without-gcing-body)
  63            ;; We need to disable interrupts before disabling GC, so
  64            ;; that signal handlers using locks don't accidentally try
  65            ;; to grab them with GC inhibited.
  66            (let ((*in-without-gcing* t))
  67              (unwind-protect
  68                   (let* ((*allow-with-interrupts* nil)
  69                          (*interrupts-enabled* nil)
  70                          (*gc-inhibit* t))
  71                     (,without-gcing-body))
  72                ;; This is not racy becuase maybe_defer_handler
  73                ;; defers signals if *GC-INHIBIT* is NIL but there
  74                ;; is a pending gc or stop-for-gc.
  75                (when (or *interrupt-pending*
  76                          *gc-pending*
  77                          #!+sb-thread *stop-for-gc-pending*)
  78                  (sb!unix::receive-pending-interrupt))))))))
  79 \f
  80 ;;; EOF-OR-LOSE is a useful macro that handles EOF.
  81 (defmacro eof-or-lose (stream eof-error-p eof-value)
  82   `(if ,eof-error-p
  83        (error 'end-of-file :stream ,stream)
  84        ,eof-value))
  85
  86 ;;; These macros handle the special cases of T and NIL for input and
  87 ;;; output streams.
  88 ;;; FIXME: should we kill the high-security feature? Or, if enabled,
  89 ;;; ensure that the designated stream has the right directionality?
  90 ;;; (Nothing prevents *TERMINAL-IO* from being bound to an output-only stream, e.g.)
  91 ;;;
  92 ;;; FIXME: Shouldn't these be functions instead of macros?
  93 (defmacro in-stream-from-designator (stream)
  94   (let ((svar (gensym)))
  95     `(let ((,svar ,stream))
  96        (cond ((null ,svar) *standard-input*)
  97              ((eq ,svar t) *terminal-io*)
  98              (t
  99                 #!+high-security
 100                 (unless (input-stream-p ,svar)
 101                   (error 'simple-type-error
 102                          :datum ,svar
 103                          :expected-type '(satisfies input-stream-p)
 104                          :format-control "~S isn't an input stream"
 105                          :format-arguments (list ,svar)))
 106                 ,svar)))))
 107 ;; As noted above, this code is a tad wasteful for probably not a huge
 108 ;; performance gain. On the other hand, where STREAM is known to be of type
 109 ;; STREAM, it produces shorter code. But we could shorten the general case:
 110 #|
 111    (lambda (x)
 112     (block nil
 113      (symbol-value
 114       (case x ((nil) '*standard-output*)
 115               ((t) '*terminal-io*)
 116               (t (return x))))))
 117 |#
 118 (defmacro out-stream-from-designator (stream)
 119   (let ((svar (gensym)))
 120     `(let ((,svar ,stream))
 121        (cond ((null ,svar) *standard-output*)
 122              ((eq ,svar t) *terminal-io*)
 123              (t
 124                 #!+high-security
 125                 (unless (output-stream-p ,svar)
 126                   (error 'simple-type-error
 127                          :datum ,svar
 128                          :expected-type '(satisfies output-stream-p)
 129                          :format-control "~S isn't an output stream."
 130                          :format-arguments (list ,svar)))
 131                 ,svar)))))
 132
 133 ;;; WITH-mumble-STREAM calls the function in the given SLOT of the
 134 ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the
 135 ;;; ARGS for FUNDAMENTAL-STREAMs.
 136 (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
 137   `(let ((stream (in-stream-from-designator ,stream)))
 138     ,(if stream-dispatch
 139          `(if (ansi-stream-p stream)
 140               (funcall (,slot stream) stream ,@args)
 141               ,@(when stream-dispatch
 142                   `(,(destructuring-bind (function &rest args) stream-dispatch
 143                        `(,function stream ,@args)))))
 144          `(funcall (,slot stream) stream ,@args))))
 145
 146 (defmacro %with-out-stream (stream (slot &rest args) &optional stream-dispatch)
 147   `(let ((stream ,stream))
 148     ,(if stream-dispatch
 149          `(if (ansi-stream-p stream)
 150               (funcall (,slot stream) stream ,@args)
 151               ,@(when stream-dispatch
 152                   `(,(destructuring-bind (function &rest args) stream-dispatch
 153                                          `(,function stream ,@args)))))
 154          `(funcall (,slot stream) stream ,@args))))
 155
 156 (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
 157   `(%with-out-stream (out-stream-from-designator ,stream)
 158                      (,slot ,@args)
 159                      ,stream-dispatch))
 160
 161 \f
 162 ;;;; These are hacks to make the reader win.
 163
 164 ;;; This macro sets up some local vars for use by the
 165 ;;; FAST-READ-CHAR macro within the enclosed lexical scope. The stream
 166 ;;; is assumed to be a ANSI-STREAM.
 167 ;;;
 168 ;;; KLUDGE: Some functions (e.g. ANSI-STREAM-READ-LINE) use these variables
 169 ;;; directly, instead of indirecting through FAST-READ-CHAR.
 170 ;;; When ANSI-STREAM-INPUT-CHAR-POS is non-null, we take care to update it,
 171 ;;; but not for each character of input.
 172 (defmacro prepare-for-fast-read-char (stream &body forms)
 173   `(let* ((%frc-stream% ,stream)
 174           (%frc-method% (ansi-stream-in %frc-stream%))
 175           (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%))
 176           (%frc-index% (ansi-stream-in-index %frc-stream%)))
 177      (declare (type (mod ,(1+ +ansi-stream-in-buffer-length+)) %frc-index%)
 178               (type ansi-stream %frc-stream%))
 179      ,@forms))
 180
 181 ;;; This macro must be called after one is done with FAST-READ-CHAR
 182 ;;; inside its scope to decache the ANSI-STREAM-IN-INDEX.
 183 ;;; To keep the amount of code injected by FAST-READ-CHAR as small as possible,
 184 ;;; we avoid bumping the absolute stream position counter at each character.
 185 ;;; When finished looping, one extra function call takes care of that.
 186 ;;; If buffer refills occurred within FAST-READ-CHAR, the refill logic
 187 ;;; similarly scans the cin-buffer before placing anything new into it.
 188 (defmacro done-with-fast-read-char ()
 189   `(progn
 190      (when (ansi-stream-input-char-pos %frc-stream%)
 191        (update-input-char-pos %frc-stream% %frc-index%))
 192      (setf (ansi-stream-in-index %frc-stream%) %frc-index%)))
 193
 194 ;;; a macro with the same calling convention as READ-CHAR, to be used
 195 ;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR.
 196 ;;; If EOF-ERROR-P is statically T (not any random expression evaluating
 197 ;;; to T) then wrap the whole thing in (TRULY-THE CHARACTER ...)
 198 ;;; because it's either going to yield a character or signal EOF.
 199 (defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
 200   (let ((result
 201          `(if (not %frc-buffer%)
 202               (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)
 203               (block nil
 204                 (when (= %frc-index% +ansi-stream-in-buffer-length+)
 205                   (let ((index-or-nil
 206                          (fast-read-char-refill %frc-stream% ,eof-error-p)))
 207                     ,@(unless (eq eof-error-p 't)
 208                         `((when (null index-or-nil)
 209                             (return ,eof-value))))
 210                     (setq %frc-index%
 211                           (truly-the (mod ,+ansi-stream-in-buffer-length+)
 212                                      index-or-nil))))
 213                 (prog1 (aref %frc-buffer%
 214                              (truly-the (mod ,+ansi-stream-in-buffer-length+)
 215                                         %frc-index%))
 216                   (incf %frc-index%))))))
 217     (cond ((eq eof-error-p 't)
 218            `(truly-the character ,result))
 219           ((and (symbolp eof-value) (constantp eof-value)
 220                 ;; use an EQL specifier only if the const is EQL-comparable
 221                 (typep (symbol-value eof-value) '(or symbol fixnum)))
 222            `(truly-the (or (eql ,(symbol-value eof-value)) character) ,result))
 223           (t
 224            result))))
 225
 226 ;;;; And these for the fasloader...
 227
 228 ;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
 229 ;;; method. The stream is assumed to be a ANSI-STREAM.
 230 ;;;
 231 ;;; FIXME: Refactor PREPARE-FOR-FAST-READ-CHAR into similar shape.
 232 (defmacro with-fast-read-byte ((type stream &optional (eof-error-p t) eof-value)
 233                                &body body)
 234   (aver (or (eq t eof-error-p) (eq t type)))
 235   (with-unique-names (f-stream f-method f-buffer f-index eof-p eof-val)
 236     `(let* ((,f-stream ,stream)
 237             (,eof-p ,eof-error-p)
 238             (,eof-val ,eof-value)
 239             (,f-method (ansi-stream-bin ,f-stream))
 240             (,f-buffer (ansi-stream-in-buffer ,f-stream))
 241             (,f-index (ansi-stream-in-index ,f-stream)))
 242        (declare (type ansi-stream ,f-stream)
 243                 (type index ,f-index))
 244        (declare (disable-package-locks fast-read-byte))
 245        (flet ((fast-read-byte ()
 246                   (,@(cond ((equal '(unsigned-byte 8) type)
 247                             ;; KLUDGE: For some reason I haven't tracked down
 248                             ;; this makes a difference even in given the TRULY-THE.
 249                             `(logand #xff))
 250                            (t
 251                             `(identity)))
 252                    (truly-the ,type
 253                               (cond
 254                                 ((not ,f-buffer)
 255                                  (funcall ,f-method ,f-stream ,eof-p ,eof-val))
 256                                 ((= ,f-index +ansi-stream-in-buffer-length+)
 257                                  (prog1 (fast-read-byte-refill ,f-stream ,eof-p ,eof-val)
 258                                    (setq ,f-index (ansi-stream-in-index ,f-stream))))
 259                                 (t
 260                                  (prog1 (aref ,f-buffer ,f-index)
 261                                    (incf ,f-index))))))))
 262          (declare (inline fast-read-byte))
 263          (declare (enable-package-locks fast-read-byte))
 264          (unwind-protect
 265               (locally ,@body)
 266            (setf (ansi-stream-in-index ,f-stream) ,f-index))))))
 267
 268 ;; This is an internal-use-only macro.
 269 (defmacro do-rest-arg (((var &optional index-var) rest-var
 270                         &optional (start 0) result)
 271                        &body body)
 272   ;; If the &REST arg never needs to be reified, this is slightly quicker
 273   ;; than using a DX list.
 274   (let ((index (sb!xc:gensym "INDEX")))
 275     `(let ((,index ,start))
 276        (loop
 277         (cond ((< (truly-the index ,index) (length ,rest-var))
 278                (let ((,var (fast-&rest-nth ,index ,rest-var))
 279                      ,@(if index-var `((,index-var ,index))))
 280                  ,@body)
 281                (incf ,index))
 282               (t
 283                (return ,result)))))))