tests/weak-hashtable.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 ;;; Apparently the entirety of 'hash.impure.lisp' is inadequate to
  13 ;;; sufficiently exercise weak hash tables.  I had a blatant omission
  14 ;;; in setting 'rehash' on a weak table, and yet no tests in that file failed.
  15 ;;;
  16 ;;; I was able to come up with this minimal examine, which I've separated
  17 ;;; out from the other tests, for better repeatability.
  18 ;;; The sensitivity to other stuff is that depending on the order in which GC
  19 ;;; observes objects, which depends on placement, it may know that weak entries
  20 ;;; are a-priori live. That's not interesting/difficult for it.
  21 ;;; The interesting case is deferring the liveness decision,
  22 ;;; which means that the symbol *V1* has to be reached only after
  23 ;;; the symbols holding weak hash tables are reached.
  24 ;;;
  25 ;;; Additionally this test demonstrates that one object
  26 ;;; can trigger multiple other objects - the symbol #:bork
  27 ;;; is a key in two tables; and an object can be triggered
  28 ;;; by more than one object - #P"turtle" is enlivened
  29 ;;; if either #:bork or #P"grumpy" is live.
  30 (defvar *a* (make-hash-table :weakness :key))
  31 (defvar *b* (make-hash-table :weakness :key))
  32 (defvar *c* (make-hash-table :weakness :key))
  33 (defvar *foo* nil)
  34 ; (setf (extern-alien "debug_weak_ht" int) 1)
  35 (let ((s (make-symbol "bork"))
  36       (v (make-array 10))
  37       (pn1 #P"grumpy")
  38       (pn2 #P"turtle"))
  39   (setf (gethash s *a*) pn1)
  40   (setf (gethash s *b*) pn2)
  41   (setf (aref v 9) (list (list s)))
  42   (setf (gethash pn1 *c*) pn2)
  43   (setq *foo* (make-weak-pointer s))
  44   (defvar *v1* v))
  45 (gc)
  46 (with-test (:name :weak-table-smoke-test)
  47   (assert (weak-pointer-value *foo*))
  48   (assert (pathnamep (gethash (weak-pointer-value *foo*) *a*)))
  49   (assert (pathnamep (gethash (weak-pointer-value *foo*) *b*))))
  50
  51 (with-test (:name :invalid-objects)
  52   (let ((hash (make-hash-table :weakness :key-and-value)))
  53     (setf (gethash 10 hash) (sb-kernel:%make-lisp-obj sb-vm:other-pointer-lowtag))
  54     (sb-ext:gc :full t)
  55     hash))