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        ;; /show was fairly useless here because it printed "/foo-ing ~A"
  35        ;; without any clue as to what the interesting THING was.
  36        ;; It could be handy for debugging package locks in bootstrap code,
  37        ;; but if package locks work fine, it's just way too much noise.
  38        (/noshow0 ,(first format))
  39        (let ((,topmost nil))
  40          ;; We use assignment and conditional restoration instead of
  41          ;; dynamic binding because we want the ignored locks
  42          ;; to propagate to the topmost context.
  43          (when (eq :invalid *ignored-package-locks*)
  44            (setf *ignored-package-locks* nil
  45                  ,topmost t))
  46          (unwind-protect
  47               (progn
  48                 ,@(ecase kind
  49                    (:symbol
  50                     `((assert-symbol-home-package-unlocked ,thing ,@format)))
  51                    (:package
  52                     `((assert-package-unlocked
  53                        (find-undeleted-package-or-lose ,thing) ,@format)))
  54                    ((nil)
  55                     `()))
  56                 ,@body)
  57            (when ,topmost
  58              (setf *ignored-package-locks* :invalid)))))))
  59
  60 (defun program-assert-symbol-home-package-unlocked (context symbol control)
  61   #!-sb-package-locks
  62   (declare (ignore context symbol control))
  63   #!+sb-package-locks
  64   (handler-bind ((package-lock-violation
  65                   (lambda (condition)
  66                     (ecase context
  67                       (:compile
  68                        (warn "Compile-time package lock violation:~%  ~A"
  69                              condition)
  70                        (sb!c:compiler-error condition))
  71                       (:eval
  72                        (eval-error condition))))))
  73     (with-single-package-locked-error (:symbol symbol control))))
  74
  75 (defmacro without-package-locks (&body body)
  76   #!+sb-doc
  77   "Ignores all runtime package lock violations during the execution of
  78 body. Body can begin with declarations."
  79   `(let (#!+sb-package-locks (*ignored-package-locks* t))
  80     ,@body))