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
#:compiler-derived-type
18 #:find-value-cell-values
19 #:find-named-callees
))
23 (unless (fboundp 'compiler-derived-type
)
24 (defknown compiler-derived-type
(t) (values t t
) (movable flushable unsafe
))
25 (deftransform compiler-derived-type
((x) * * :node node
)
26 (sb-c::delay-ir1-transform node
:optimize
)
27 `(values ',(type-specifier (sb-c::lvar-type x
)) t
))
28 (defun compiler-derived-type (x)
32 (defun find-value-cell-values (fun)
33 (let ((code (fun-code-header (%fun-fun fun
))))
34 (loop for i from sb-vm
::code-constants-offset below
(get-header-data code
)
35 for c
= (code-header-ref code i
)
36 when
(= sb-vm
::value-cell-header-widetag
(widetag-of c
))
37 collect
(sb-vm::value-cell-ref c
))))
39 (defun find-named-callees (fun &key
(type t
) (name nil namep
))
40 (let ((code (sb-kernel:fun-code-header
(sb-kernel:%fun-fun fun
))))
41 (loop for i from sb-vm
::code-constants-offset below
(sb-kernel:get-header-data code
)
42 for c
= (sb-kernel:code-header-ref code i
)
43 when
(and (typep c
'sb-impl
::fdefn
)
44 (let ((fun (sb-impl::fdefn-fun c
)))
47 (equal name
(sb-impl::fdefn-name c
))))))
48 collect
(sb-impl::fdefn-fun c
))))