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 program-assert-symbol-home-package-unlocked (context symbol control)
  57   #!-sb-package-locks
  58   (declare (ignore context symbol control))
  59   #!+sb-package-locks
  60   (handler-bind ((package-lock-violation
  61                   (lambda (condition)
  62                     (ecase context
  63                       (:compile
  64                        (warn "Compile-time package lock violation:~%  ~A"
  65                              condition)
  66                        (sb!c:compiler-error condition))
  67                       (:eval
  68                        (eval-error condition))))))
  69     (with-single-package-locked-error (:symbol symbol control))))
  70
  71 (defmacro without-package-locks (&body body)
  72   #!+sb-doc
  73   "Ignores all runtime package lock violations during the execution of
  74 body. Body can begin with declarations."
  75   `(let (#!+sb-package-locks (*ignored-package-locks* t))
  76     ,@body))
  77
  78 (!defun-from-collected-cold-init-forms !early-package-cold-init)