mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1f5238fe0b
This change has the overall effect of having the evaluator properly separate out top level code from any defined functions. See the new test :EVAL-TOP-LEVEL-CODE-SEPARATE-COMPONENT and the existing tests :STRUCTURE-SLOT-VALUE-IN-METHOD-NO-CALLEES and :STRUCTURE-MISSING-SLOT-VALUE-IN-METHOD-SINGLE-CALLEE. As a bonus, self call recognition works for COMPILE now. As a side effect, we (correctly) get more redefinition warnings as well (for example for WARN during bootstrap), which were missing before for some reason. In order to achieve this, the following needs to be done: * COMPILE does not have its own special way of doing ir1 conversion for lambdas anymore, instead relying on the top level lambda machinery to separate out the actual compiled code. This gives the correct semantics for policy and compilation etc. for free without special or duplicate logic, and removes all the stuff around HAS-EXTERNAL-REFERENCES-P, which was an idea that was never really finished. This allows us to extend COMPILE-IN-LEXENV to evaluate forms directly and hence allow %SIMPLE-EVAL to not have to manually wrap the lambdas either, so evaluation-via-compilation behaves like top-level evaluation by the file compiler (of course without file compilation semantics). LTV processing and fasteval also can just evaluate forms directly with EVAL-WITH-COMPILE-IN-LEXENV. * Storing source forms should always be off for PCL generated functions, revealed by the clos-arena test. This was probably not detected before because the policy inheritance was subtly wrong. * Fix some tests to not rely on questionable behavior of how named COMPILE interacts with global type information. Such behavior should only work in compile file mode. * The TL-XEP debug name had nothing to do with the actual TL-XEP functional kind, which was confusing. * TIME now counts all lambda conversions. Just ignoring the entry points produced by COMPILE for the top level lambda didn't make much sense since all other kinds of entry points get counted. It's there purely to give a hint to the user how much work the compiler is doing, not to count anything in the source being compiled. * Core components need to have patch tables again. The fact that they are exercised in warm bootstrap now means that we are likely actually using the load time code stripping functionality not just in theory, vut in practice as well. * Add post ir1-toplevel processing smashing of names onto compiled functions again to get names right. As an added bonus, this allows us to get recognize self calls working for COMPILE functions. * core debug source infos never actually used the function slot, and it's not clear what function to give it when evaluating top level forms, so delete it. * Also fix > 3 decade old bug in MAKE-LISP-SOURCE-INFO in which a plain vector was used when one with a fill pointer was expected. I guess this code path hadn't been exercised in a long time.
154 lines
6.3 KiB
Common Lisp
154 lines
6.3 KiB
Common Lisp
;;;; Tests of SLOT-VALUE
|
|
|
|
(load "compiler-test-util.lisp")
|
|
(defpackage "SLOT-VALUE-TEST"
|
|
(:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL"))
|
|
|
|
(in-package "SLOT-VALUE-TEST")
|
|
|
|
(defclass a-class ()
|
|
((x :initform 123)))
|
|
|
|
(defun a-class-x-0 (a)
|
|
(slot-value a 'x))
|
|
|
|
(defmethod a-class-x-1 ((a a-class))
|
|
(slot-value a 'x))
|
|
|
|
(defmethod a-class-x-2 ((a a-class))
|
|
(let ((%a a))
|
|
(slot-value %a 'x)))
|
|
|
|
(defmethod a-class-x-3 ((a t))
|
|
(slot-value a 'x))
|
|
|
|
(with-test (:name (slot-value defun))
|
|
(assert (= (a-class-x-0 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod))
|
|
(assert (= (a-class-x-1 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod let))
|
|
(assert (= (a-class-x-2 (make-instance 'a-class)) 123)))
|
|
|
|
(with-test (:name (slot-value defmethod t))
|
|
(assert (= (a-class-x-3 (make-instance 'a-class)) 123)))
|
|
|
|
(defun read-slot-way1 (instance slot)
|
|
(slot-value instance slot))
|
|
(defun read-slot-way2 (instance slot)
|
|
(slot-value (the structure-object instance) slot))
|
|
(compile 'read-slot-way1)
|
|
(compile 'read-slot-way2)
|
|
|
|
;;; Collect up a bunch of instances that are subtypes of STRUCTURE-OBJECT
|
|
;;; I've seen mismatch occur in the SLOT-VALUE calls, so I've inserted logic
|
|
;;; to exclude expected faillures.
|
|
;;; (I guess the finalizer thread manipulates hash-tables while this thread runs?)
|
|
(with-test (:name :fast-structure-slot-value)
|
|
(let ((instances
|
|
(sb-vm:list-allocated-objects
|
|
:all :type sb-vm:instance-widetag
|
|
:test (lambda (x)
|
|
(and (typep x 'structure-object)
|
|
;; want to ensure the instances under test are mostly immutable.
|
|
;; This is no guarantee, but it works.
|
|
(eq (sb-kernel:generation-of x)
|
|
sb-vm:+pseudo-static-generation+)))
|
|
:count 10000)))
|
|
(dolist (x instances)
|
|
(let* ((layout (sb-kernel:%instance-layout x))
|
|
(dd (sb-kernel:layout-dd layout)))
|
|
(dolist (dsd (sb-kernel:dd-slots dd))
|
|
(let ((slot-name (sb-kernel:dsd-name dsd)))
|
|
;; some slots may be raw, don't worry about being EQ
|
|
(unless (eql (read-slot-way1 x slot-name)
|
|
(read-slot-way2 x slot-name))
|
|
(unless (and (hash-table-p x) (eq slot-name 'sb-impl::cache))
|
|
(error "Failed on ~s ~s" x slot-name)))))))))
|
|
|
|
(defstruct a-struct x)
|
|
(defstruct (another-struct (:include a-struct)) y)
|
|
|
|
(defmethod read-a-struct-x ((o a-struct))
|
|
(slot-value o 'x))
|
|
(defmethod read-a-struct-y ((o a-struct))
|
|
(slot-value o 'y))
|
|
|
|
(with-test (:name :fast-structure-slot-value-in-method)
|
|
(assert (eql (read-a-struct-x (make-a-struct :x 42)) 42))
|
|
(assert (eql (read-a-struct-x (make-another-struct :x 43 :y 44)) 43))
|
|
(assert-error (read-a-struct-y (make-a-struct :x 45)) sb-pcl::missing-slot)
|
|
(assert (eql (read-a-struct-y (make-another-struct :x 46 :y 47)) 47)))
|
|
|
|
(with-test (:name :structure-slot-value-in-method-actually-fast
|
|
:skipped-on (not (or :x86 :x86-64)))
|
|
(let* ((method (find-method #'read-a-struct-x nil (list (find-class 'a-struct))))
|
|
(lines (ctu:disassembly-lines (sb-mop:method-function method))))
|
|
(assert (notany (lambda (x) (search "CALL" x)) lines))
|
|
(assert (notany (lambda (x) (search "JMP" x)) lines))))
|
|
|
|
(with-test (:name :structure-slot-value-in-method-no-callees)
|
|
(let* ((method (find-method #'read-a-struct-x nil (list (find-class 'a-struct))))
|
|
(mf (sb-mop:method-function method))
|
|
(fmf (sb-pcl::%method-function-fast-function mf))
|
|
(callees (ctu:find-named-callees fmf)))
|
|
(ecase sb-ext:*evaluator-mode*
|
|
(:interpret)
|
|
(:compile
|
|
(assert (null callees))))))
|
|
|
|
(with-test (:name :structure-missing-slot-value-in-method-calls-global
|
|
:skipped-on (not (or :x86 :x86-64)))
|
|
(let* ((method (find-method #'read-a-struct-y nil (list (find-class 'a-struct))))
|
|
(lines (ctu:disassembly-lines (sb-mop:method-function method))))
|
|
(assert (some (lambda (x) (search "SB-PCL::STRUCTURE-SLOT-VALUE" x)) lines))))
|
|
|
|
(with-test (:name :structure-missing-slot-value-in-method-single-callee)
|
|
(let* ((method (find-method #'read-a-struct-y nil (list (find-class 'a-struct))))
|
|
(mf (sb-mop:method-function method))
|
|
(fmf (sb-pcl::%method-function-fast-function mf))
|
|
(callees (ctu:find-named-callees fmf)))
|
|
(ecase sb-ext:*evaluator-mode*
|
|
(:interpret)
|
|
(:compile
|
|
(assert (equal callees '(sb-pcl::structure-slot-value)))))))
|
|
|
|
(define-condition a-condition () ((a :initarg :a)))
|
|
(defmethod sb-mop:slot-value-using-class :around (class (c a-condition) slotd)
|
|
(list :a-slot-value (call-next-method)))
|
|
(with-test (:name :condition-slot-value-using-class-method)
|
|
(assert (equal (slot-value (make-condition 'a-condition :a 4) 'a) '(:a-slot-value 4))))
|
|
|
|
(defstruct cfg-struct-type1 name)
|
|
(defstruct cfg-struct-type2 identifier name)
|
|
(defstruct cfg-struct-type3 name)
|
|
(defun configuration-structure-name-good (x)
|
|
(slot-value (the (or cfg-struct-type1 cfg-struct-type2 cfg-struct-type3) x) 'name))
|
|
(defun configuration-structure-name-best (x)
|
|
(slot-value (the (or cfg-struct-type1 cfg-struct-type2) x) 'name))
|
|
(compile 'configuration-structure-name-good)
|
|
(compile 'configuration-structure-name-best)
|
|
(with-test (:name :structure-slot-value-2-possible-instance-types)
|
|
(let ((callees (ctu:find-named-callees #'configuration-structure-name-good)))
|
|
(assert (find 'sb-pcl::structure-slot-value callees)))
|
|
(let ((callees (ctu:find-named-callees #'configuration-structure-name-best)))
|
|
(assert (not (find 'sb-pcl::structure-slot-value callees)))))
|
|
|
|
(defun read-slot-of-maybe-struct (x)
|
|
(declare (type (or null cfg-struct-type3) x))
|
|
(with-slots (name) x name))
|
|
|
|
(compile 'read-slot-of-maybe-struct)
|
|
|
|
(defmethod slot-missing ((class (eql (find-class 'null))) the-object slot op &optional new)
|
|
(declare (ignore new))
|
|
(if (and (eq slot 'name) (eq op 'slot-value)) :i-was-called))
|
|
|
|
(with-test (:name :slot-value-nullable-instance)
|
|
(let ((callees (ctu:find-named-callees #'read-slot-of-maybe-struct)))
|
|
(assert (and (sb-int:singleton-p callees)
|
|
(eq (car callees) 'sb-pcl::nil-not-slot-object)))
|
|
(assert (eq 'steve (read-slot-of-maybe-struct (make-cfg-struct-type3 :name 'steve))))
|
|
(assert (eq :i-was-called (read-slot-of-maybe-struct nil)))))
|