1 ;;;; Utilities for verifying features of compiled code
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (defpackage :compiler-test-util
16 (:use
:cl
:sb-c
:sb-kernel
)
17 (:export
#:assert-consing
19 #:compiler-derived-type
20 #:find-value-cell-values
22 #:find-named-callees
))
26 (unless (fboundp 'compiler-derived-type
)
27 (defknown compiler-derived-type
(t) (values t t
) (movable flushable unsafe
))
28 (deftransform compiler-derived-type
((x) * * :node node
)
29 (sb-c::delay-ir1-transform node
:optimize
)
30 `(values ',(type-specifier (sb-c::lvar-type x
)) t
))
31 (defun compiler-derived-type (x)
35 (defun find-value-cell-values (fun)
36 (let ((code (fun-code-header (%fun-fun fun
))))
37 (loop for i from sb-vm
::code-constants-offset below
(get-header-data code
)
38 for c
= (code-header-ref code i
)
39 when
(= sb-vm
::value-cell-header-widetag
(widetag-of c
))
40 collect
(sb-vm::value-cell-ref c
))))
42 (defun find-named-callees (fun &key
(type t
) (name nil namep
))
43 (let ((code (sb-kernel:fun-code-header
(sb-kernel:%fun-fun fun
))))
44 (loop for i from sb-vm
::code-constants-offset below
(sb-kernel:get-header-data code
)
45 for c
= (sb-kernel:code-header-ref code i
)
46 when
(and (typep c
'sb-impl
::fdefn
)
47 (let ((fun (sb-impl::fdefn-fun c
)))
50 (equal name
(sb-impl::fdefn-name c
))))))
51 collect
(sb-impl::fdefn-fun c
))))
53 (defun find-code-constants (fun &key
(type t
))
54 (let ((code (sb-kernel:fun-code-header
(sb-kernel:%fun-fun fun
))))
55 (loop for i from sb-vm
::code-constants-offset below
(sb-kernel:get-header-data code
)
56 for c
= (sb-kernel:code-header-ref code i
)
60 (defmacro assert-no-consing
(form &optional times
)
61 `(%assert-no-consing
(lambda () ,form
) ,times
))
62 (defun %assert-no-consing
(thunk &optional times
)
63 (let ((before (sb-ext:get-bytes-consed
))
64 (times (or times
10000)))
65 (declare (type (integer 1 *) times
))
68 (assert (< (- (sb-ext:get-bytes-consed
) before
) times
))))
70 (defmacro assert-consing
(form &optional times
)
71 `(%assert-consing
(lambda () ,form
) ,times
))
72 (defun %assert-consing
(thunk &optional times
)
73 (let ((before (sb-ext:get-bytes-consed
))
74 (times (or times
10000)))
75 (declare (type (integer 1 *) times
))
78 (assert (not (< (- (sb-ext:get-bytes-consed
) before
) times
)))))