mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
dd0f579028
The feature was checked-in without being completed and it's already bitrotted. Wrapper is folded back into layout name-wise for the most part now because that's how it's been effectively functioning. There are still probably more cleanups to be done, related to this, but this takes care of most of the dead code and unnecessary layers of alternate names/indirection.
94 lines
3.3 KiB
Common Lisp
94 lines
3.3 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(eval-when (:compile-toplevel)
|
|
(load "compiler-test-util.lisp"))
|
|
|
|
;;; This test asserts that each constructor for a defstruct involved in a
|
|
;;; mutually referential cycle with other defstructs inlines the test of the
|
|
;;; as-yet-unseen type when the DEFSTRUCT form is first read.
|
|
;;; We can tell that they're inlined because they use layout-IDs, so the only
|
|
;;; boxed constant is for the constructor to deposit a layout.
|
|
(with-test (:name (:block-compile :defstruct-slot-type-circularity))
|
|
(with-scratch-file (fasl "fasl")
|
|
(compile-file "block-compile-defstruct-test.lisp" :output-file fasl :block-compile t)
|
|
(load fasl))
|
|
(dolist (symbol '(make-s1 make-s2 make-s3))
|
|
(let ((constants
|
|
(ctu:find-code-constants (symbol-function symbol)
|
|
:type 'sb-kernel:layout)))
|
|
(assert (= (length constants) 1)))))
|
|
|
|
(with-test (:name :mutex-owner-typecheck)
|
|
(let ((layouts
|
|
(ctu:find-code-constants #'(setf sb-thread::mutex-%owner)
|
|
:type 'sb-kernel:layout)))
|
|
;; expect exactly 1 layout, that of MUTEX, for signaling OBJECT-NOT-TYPE.
|
|
;; To be really pedantic we'd want to assert that in the source file
|
|
;; the defstruct of MUTEX appears prior to the defstruct of THREAD,
|
|
;; proving without a doubt that block compilation worked.
|
|
(assert (= (length layouts) 1))
|
|
(assert (find (sb-kernel:find-layout 'sb-thread:mutex)
|
|
layouts))))
|
|
|
|
(defstruct (parent)
|
|
(bv #* :type bit-vector)
|
|
(x 0d0 :type double-float))
|
|
(defstruct (child (:include parent))
|
|
(w 0 :type word))
|
|
(defstruct (child2 (:include parent
|
|
(bv #* :type simple-bit-vector))))
|
|
|
|
#|
|
|
Timing result:
|
|
(defparameter *l1*
|
|
(coerce (loop repeat 1000
|
|
for i from 2
|
|
collect (make-child :x (coerce i 'double-float)
|
|
:w (1+ i)))
|
|
'vector))
|
|
|
|
(defparameter *l2* (map 'vector 'copy-structure *l1*))
|
|
|
|
(defun test (n)
|
|
(loop repeat (The fixnum n)
|
|
sum (loop for s1 across *l1*
|
|
for s2 across *l2*
|
|
count (equalp s1 s2) fixnum) fixnum))
|
|
|
|
* (time (test 1000))
|
|
Old:
|
|
Evaluation took:
|
|
0.046 seconds of real time
|
|
127,769,104 processor cycles
|
|
New:
|
|
Evaluation took:
|
|
0.024 seconds of real time
|
|
66,055,457 processor cycles
|
|
|#
|
|
|
|
(with-test (:name :custom-equalp)
|
|
(assert (equalp (make-child :x -0d0 :w #xf00f :bv #*10101)
|
|
(make-child :x +0d0 :w #xf00f :bv #*10101))))
|
|
|
|
(with-test (:name :no-equalp-calls)
|
|
(dolist (type '(parent child child2))
|
|
(let* ((equalp-impl
|
|
(sb-kernel:layout-equalp-impl (sb-kernel:find-layout type)))
|
|
(callees
|
|
(ctu:find-named-callees equalp-impl)))
|
|
(case type
|
|
((parent child)
|
|
(assert (equal callees `(,#'sb-int:bit-vector-=))))
|
|
(child2
|
|
;; EQUAL on SIMPLE-BIT-VECTOR gets open-coded
|
|
(assert (not callees)))))))
|