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 (!begin-collecting-cold-init-forms)
  16
  17 ;;; Unbound outside package lock context, inside either list of
  18 ;;; packages for which locks are ignored, T when locks for
  19 ;;; all packages are ignored, and :invalid outside package-lock
  20 ;;; context. FIXME: This needs to be rebound for each thread.
  21 (defvar *ignored-package-locks*
  22   (error "*IGNORED-PACKAGE-LOCKS* should be set up in cold-init."))
  23 (!cold-init-forms
  24   (setf *ignored-package-locks* :invalid))
  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        (/show0 ,(first format))
  35        (let ((,topmost nil))
  36          ;; We use assignment and conditional restoration instead of
  37          ;; dynamic binding because we want the ignored locks
  38          ;; to propagate to the topmost context.
  39          (when (eq :invalid *ignored-package-locks*)
  40            (setf *ignored-package-locks* nil
  41                  ,topmost t))
  42          (unwind-protect
  43               (progn
  44                 ,@(ecase kind
  45                    (:symbol
  46                     `((assert-symbol-home-package-unlocked ,thing ,@format)))
  47                    (:package
  48                     `((assert-package-unlocked
  49                        (find-undeleted-package-or-lose ,thing) ,@format)))
  50                    ((nil)
  51                     `()))
  52                 ,@body)
  53            (when ,topmost
  54              (setf *ignored-package-locks* :invalid)))))))
  55
  56 (defun compiler-assert-symbol-home-package-unlocked (symbol control)
  57   #!-sb-package-locks
  58   (declare (ignore symbol control))
  59   #!+sb-package-locks
  60   (flet ((resignal (condition)
  61            ;; Signal the condition to give user defined handlers a chance,
  62            ;; if they decline convert to compiler-error.
  63            (signal condition)
  64            (sb!c:compiler-error condition)))
  65     (handler-bind ((package-lock-violation #'resignal))
  66       (with-single-package-locked-error ()
  67         (assert-symbol-home-package-unlocked symbol control)))))
  68
  69 (defmacro without-package-locks (&body body)
  70   #!+sb-doc
  71   "Ignores all runtime package lock violations during the execution of
  72 body. Body can begin with declarations."
  73   `(let (#!+sb-package-locks (*ignored-package-locks* t))
  74     ,@body))
  75
  76 (!defun-from-collected-cold-init-forms !early-package-cold-init)