tests/do-refs.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 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package sb-vm)
  13
  14 (test-util:with-test (:name :safe-layoutless-instance)
  15   (assert (not (sb-vm::references-p (sb-kernel:%make-instance 5) '(foo)))))
  16
  17 (defun collect-slot-values (obj &aux result)
  18   (flet ((slots (x)
  19            (push x result)))
  20     (do-referenced-object (obj slots))
  21     (nreverse result)))
  22
  23 (defun walk-slots-test (obj expect)
  24   (assert (equal (collect-slot-values obj) expect)))
  25 (defun walk-slots-test* (obj test)
  26   (assert (funcall test (collect-slot-values obj))))
  27
  28 (defstruct foo (z 0 :type sb-ext:word) (x 'x) (y 'y))
  29
  30 (test-util:with-test (:name :walk-slots-trivial ; lists and vectors
  31                             :fails-on :interpreter)
  32   (walk-slots-test '(a . b) '(a b))
  33   (walk-slots-test #(a b c) '(a b c))
  34   (walk-slots-test #(a b c d) '(a b c d))
  35   (walk-slots-test (make-foo) `(,(find-layout 'foo) x y))
  36   )
  37
  38 (test-util:with-test (:name :walk-slots-numbers
  39                       :fails-on :interpreter)
  40   (let ((c #c(45d0 33d0)))
  41     (walk-slots-test c nil))
  42   (let ((r 22/7))
  43     (walk-slots-test r '(22 7))))
  44
  45 (test-util:with-test (:name :walk-slots-fancy-array)
  46   (let* ((inner (make-array 10 :element-type 'character))
  47          (a (make-array 10 :element-type 'character :displaced-to inner)))
  48     (walk-slots-test a (list inner t nil))))
  49
  50 (test-util:with-test (:name :walk-slots-symbol
  51                       :fails-on :interpreter)
  52   (let* ((name "ZOT")
  53          (s (make-symbol name))
  54          (info '((bork 42))))
  55     (import s "CL-USER")
  56     (set s 'hi)
  57     (setf (symbol-plist s) (car info) info (sb-kernel:symbol-%info s))
  58     ;; ASSUMPTION: slot ordering
  59     (walk-slots-test s `(hi ,info ,name ,(find-package "CL-USER")))))
  60
  61 (test-util:with-test (:name :walk-slots-closure)
  62   (let ((c (funcall (compile nil '(lambda (a b c)
  63                                    (lambda (x) (+ x (incf a) (incf b) (incf c)))))
  64                     8 9 10)))
  65     (walk-slots-test* c
  66                       (lambda (x)
  67                         (and (= (length x) 4)
  68                              (functionp (first x))
  69                              (not (find sb-vm:value-cell-widetag (cdr x)
  70                                         :key 'widetag-of :test #'/=)))))))
  71
  72 (test-util:with-test (:name :walk-slots-fdefn)
  73   (let* ((closure (funcall (compile nil '(lambda (x)  (lambda () x))) t))
  74          (fname `(cas ,(gensym))))
  75     (setf (fdefinition fname) closure)
  76     (walk-slots-test*
  77      (sb-int:find-fdefn fname)
  78      (lambda (slots)
  79        #+(and immobile-code x86-64)
  80        (and (= (length slots) 3)
  81             (equal (first slots) fname)
  82             (closurep (second slots))
  83             (funcallable-instance-p (third slots)))
  84        #-(and immobile-code x86-64)
  85        (and (= (length slots) 2)
  86             (equal (first slots) fname)
  87             (closurep (second slots)))))))
  88
  89 (defclass mystdinst ()
  90   ((a :initform 1) (b :initform 2)
  91    (c :initform 3) (d :initform 4) (e :initform 5)))
  92
  93 (test-util:with-test (:name :walk-slots-standard-instance
  94                             :fails-on :interpreter)
  95   (let ((o (make-instance 'mystdinst)))
  96     (walk-slots-test* o
  97                       (lambda (slots)
  98                         (destructuring-bind (layout clos-slots) slots
  99                           (and (eq layout (%instance-layout o))
 100                                (eq clos-slots (sb-pcl::std-instance-slots o))))))))
 101
 102 (define-condition cfoo (simple-condition) ((a :initarg :a) (b :initarg :b) (c :initform 'c)))
 103 (test-util:with-test (:name :walk-slots-condition-instance
 104                             :fails-on :interpreter)
 105   (let ((instance (make-condition 'cfoo :a 'ay :b 'bee :format-arguments "wat")))
 106     (walk-slots-test instance
 107                      `(,(find-layout 'cfoo) ((c . c) (format-control . nil))
 108                        :a  ay :b bee :format-arguments "wat"))))
 109
 110 (defun make-random-funinstance (&rest values)
 111   (let* ((ctor (apply #'sb-pcl::%make-ctor values))
 112          (layout (sb-kernel:%fun-layout ctor)))
 113     ;; If the number of payload words is even, then there's a padding word
 114     ;; because adding the header makes the unaligned total an odd number.
 115     ;; Fill that padding word with something - it should not be visible.
 116     ;; Whether GC should trace the word is a different question,
 117     ;; on whose correct answer I waver back and forth.
 118     (when (evenp (sb-kernel:get-closure-length ctor)) ; payload length
 119       (let ((max (reduce #'max (sb-kernel:dd-slots (sb-kernel:layout-dd layout))
 120                          :key 'sb-kernel:dsd-index)))
 121         (setf (sb-kernel:%funcallable-instance-info ctor (1+ max))
 122               (elt sb-vm:+static-symbols+ 0))))
 123     ;; stuff in a random function as the implementation
 124     (setf (sb-kernel:%funcallable-instance-fun ctor) #'error)
 125     ctor))
 126 (compile 'make-random-funinstance)
 127
 128 (test-util:with-test (:name :walk-slots-pcl-ctor)
 129   (let* ((slot-vals '("A" "B" "C" "D" "E" "F"))
 130          (f (apply #'make-random-funinstance slot-vals)))
 131     (walk-slots-test f `(,(find-layout 'sb-pcl::ctor) ,#'error ,@slot-vals))))
 132
 133 #+sb-fasteval
 134 (test-util:with-test (:name :walk-slots-interpreted-fun)
 135   (let ((f (let ((sb-ext:*evaluator-mode* :interpret))
 136              (eval '(lambda (x y z))))))
 137     (funcall f 1 2 3) ; compute the digested slots
 138     (walk-slots-test* f
 139                       (lambda (slots)
 140                         (destructuring-bind (type fin-fun a b c d) slots
 141                           (declare (ignore a b c))
 142                           (and (typep type 'layout)
 143                                (typep fin-fun 'closure)
 144                                (typep d '(and integer (not (eql 0))))))))))
 145
 146 (test-util:with-test (:name :deep-sizer)
 147   (multiple-value-bind (tot-bytes n-kids)
 148       (test-util:deep-size #(a b c d (e f) #*0101))
 149     ;; 8 words for the vector
 150     ;; 4 words for 2 conses
 151     ;; 4 words for a bit-vector: header/length/bits/padding
 152     (assert (= tot-bytes (* 16 n-word-bytes)))
 153     ;; 2 conses and 1 bit-vector
 154     (assert (= n-kids 3))))
 155
 156 (defvar *some-symbol* 'a)
 157 (test-util:with-test (:name :symbol-refs
 158                       :fails-on :interpreter)
 159   (sb-int:collect ((results))
 160     (let ((*some-symbol* 'b))
 161       (do-referenced-object ('*some-symbol* results)))
 162     (assert (eq (first (results)) #+sb-thread 'a
 163                                   #-sb-thread 'b))))