src/code/early-package.lisp

   1 ;;;; Package (locking) related macros needed on the target before most
   2 ;;;; of the package machinery is available.
   3 ;;;;
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 ;;; Unbound outside package lock context, inside either list of
  16 ;;; packages for which locks are ignored, T when locks for
  17 ;;; all packages are ignored, and :invalid outside package-lock
  18 ;;; context. FIXME: This needs to be rebound for each thread.
  19 (!defvar *ignored-package-locks* :invalid)
  20
  21 ;; This proclamation avoids a ton of style warnings due to so many calls
  22 ;; that get cross-compiled prior to compiling "target-package.lisp"
  23 (declaim (ftype (sfunction ((or symbol list) &optional (or string function) &rest t) t)
  24                 assert-symbol-home-package-unlocked))
  25
  26 (defmacro with-single-package-locked-error ((&optional kind thing &rest format)
  27                                             &body body)
  28   #!-sb-package-locks (declare (ignore kind thing format))
  29   #!-sb-package-locks
  30   `(progn ,@body)
  31   #!+sb-package-locks
  32   (with-unique-names (topmost)
  33     `(progn
  34        (let ((,topmost nil))
  35          ;; We use assignment and conditional restoration instead of
  36          ;; dynamic binding because we want the ignored locks
  37          ;; to propagate to the topmost context.
  38          (when (eq :invalid *ignored-package-locks*)
  39            (setf *ignored-package-locks* nil
  40                  ,topmost t))
  41          (unwind-protect
  42               (progn
  43                 ,@(ecase kind
  44                    (:symbol
  45                     `((assert-symbol-home-package-unlocked ,thing ,@format)))
  46                    (:package
  47                     `((assert-package-unlocked
  48                        (find-undeleted-package-or-lose ,thing) ,@format)))
  49                    ((nil)
  50                     `()))
  51                 ,@body)
  52            (when ,topmost
  53              (setf *ignored-package-locks* :invalid)))))))
  54
  55 (defmacro without-package-locks (&body body)
  56   "Ignores all runtime package lock violations during the execution of
  57 body. Body can begin with declarations."
  58   `(let (#!+sb-package-locks (*ignored-package-locks* t))
  59     ,@body))