src/code/weak.lisp

   1 ;;;; weak pointer support
   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 ;; "new" weak vectors satisfy weak-pointer-p, not simple-vector-p
  15 #+weak-vector-readbarrier
  16 (progn
  17   (defun weak-vector-p (x)
  18     (and (weak-pointer-p x)
  19          (= (logand (get-header-data x) #xFF) 0)))
  20   (defun weak-vector-len (thing)
  21     ;; FIXME: assert that it's a vector-like weak pointer, otherwise it'll see
  22     ;; the weak-pointer-value slot.
  23     (%array-fill-pointer thing))
  24   (defun weak-vector-ref (vector index) ; TODO: needs dimension check and read barrier
  25     (sb-vm::%weakvec-ref vector index))
  26   (defun (setf weak-vector-ref) (newval vector index)
  27     (sb-vm::%weakvec-set vector index newval)
  28     newval)
  29   ;; A weak key/value-vector is primitive type SIMPLE-VECTOR based on its widetag,
  30   ;; but requires a read barrier to ensure that access does not race with GC
  31   ;; while GC is trying to clear the otherwise-unreachable references.
  32   ;; These are stubs. The real implementation needs a mutex, thought better
  33   ;; would be a reader/writer lock, since several threads may all read.
  34   ;; On the other hand, our weak tables are always synchronized by a lisp mutex
  35   ;; now and I don't plan to change that any time soon.
  36   (defun sb-impl::weak-kvv-ref (vector index)
  37     (svref vector index))
  38   (defun (cas sb-impl::weak-kvv-ref) (old new vector index)
  39     (funcall #'(cas svref) old new vector index))
  40   (defun list-from-weak-vector (v)
  41     (collect ((result))
  42       (dotimes (i (weak-vector-len v) (result))
  43         (result (weak-vector-ref v i))))))
  44
  45 #-weak-vector-readbarrier
  46 ;; legacy implementation of weak vector is basically SIMPLE-VECTOR
  47 (defun weak-vector-p (x)
  48   (and (simple-vector-p x)
  49        (test-header-data-bit x (ash sb-vm:vector-weak-flag sb-vm:array-flags-data-position))))
  50
  51 (defun make-weak-vector (length &key (initial-contents nil contents-p)
  52                                      (initial-element nil element-p))
  53   (declare (index length))
  54   (when (and element-p contents-p)
  55     (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
  56   ;; Since weak vectors are not in theory merely arrays any more, but potentially
  57   ;; some kind of weak pointers with a varing enumber of slots, this isn't badly
  58   ;; OAOO-violating in regard to make-array transforms.
  59   (when contents-p
  60     (let ((contents-length (length initial-contents)))
  61       (unless (eql length contents-length)
  62         (error "~S has ~D elements, vector length is ~D."
  63                :initial-contents contents-length length))))
  64   (let ((v (sb-c::allocate-weak-vector length)))
  65     (if initial-contents
  66         (dotimes (i length)
  67           (setf (weak-vector-ref v i) (elt initial-contents i)))
  68           ;; 0 is the usual default initial element for arrays, but all weak objects use NIL
  69         (dotimes (i length)
  70           (setf (weak-vector-ref v i) initial-element)))
  71     v))
  72 (defun make-weak-pointer (object)
  73   "Allocate and return a weak pointer which points to OBJECT."
  74   (make-weak-pointer object))
  75
  76 (declaim (inline weak-pointer-value))
  77 (defun weak-pointer-value (weak-pointer)
  78   "If WEAK-POINTER is valid, return the value of WEAK-POINTER and T.
  79 If the referent of WEAK-POINTER has been garbage collected,
  80 returns the values NIL and NIL."
  81   (declare (type weak-pointer weak-pointer))
  82   (let ((value (sb-vm::%weak-pointer-value weak-pointer)))
  83     (if (sb-vm::unbound-marker-p value)
  84         (values nil nil)
  85         (values value t))))