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
21 #:find-value-cell-values
24 #:find-anonymous-callees
29 (unless (fboundp 'compiler-derived-type
)
30 (defknown compiler-derived-type
(t) (values t t
) (flushable))
31 (deftransform compiler-derived-type
((x) * * :node node
)
32 (sb-c::delay-ir1-transform node
:optimize
)
33 `(values ',(type-specifier (sb-c::lvar-type x
)) t
))
34 (defun compiler-derived-type (x)
38 (defun find-value-cell-values (fun)
39 (let ((code (fun-code-header (%fun-fun fun
))))
40 (loop for i from sb-vm
:code-constants-offset below
(code-header-words code
)
41 for c
= (code-header-ref code i
)
42 when
(= sb-vm
:value-cell-header-widetag
(widetag-of c
))
43 collect
(sb-vm::value-cell-ref c
))))
45 (defun find-named-callees (fun &key
(type t
) (name nil namep
))
46 (let ((code (fun-code-header (%fun-fun fun
))))
47 (loop for i from sb-vm
:code-constants-offset below
(code-header-words code
)
48 for c
= (code-header-ref code i
)
49 when
(and (typep c
'sb-impl
::fdefn
)
50 (let ((fun (sb-impl::fdefn-fun c
)))
53 (equal name
(sb-impl::fdefn-name c
))))))
54 collect
(sb-impl::fdefn-fun c
))))
56 (defun find-anonymous-callees (fun &key
(type 'function
))
57 (let ((code (fun-code-header (%fun-fun fun
))))
58 (loop for i from sb-vm
:code-constants-offset below
(code-header-words code
)
59 for fun
= (code-header-ref code i
)
63 (defun find-code-constants (fun &key
(type t
))
64 (let ((code (fun-code-header (%fun-fun fun
))))
65 (loop for i from sb-vm
:code-constants-offset below
(code-header-words code
)
66 for c
= (code-header-ref code i
)
70 (defun collect-consing-stats (thunk times
)
71 (declare (type function thunk
))
72 (declare (type fixnum times
))
73 (let ((before (sb-ext:get-bytes-consed
)))
76 (values before
(sb-ext:get-bytes-consed
))))
78 (defun check-consing (yes/no form thunk times
)
79 (multiple-value-bind (before after
)
80 (collect-consing-stats thunk times
)
81 (let ((consed-bytes (- after before
)))
82 (assert (funcall (if yes
/no
#'not
#'identity
)
83 ;; I do not know why we do this comparasion,
84 ;; the original code did, so I let it
85 ;; in. Perhaps to prevent losage on GC
86 ;; fluctuations, or something. --TCR.
87 (< consed-bytes times
))
89 "~@<Expected the form ~
91 ~:[NOT to cons~;to cons~], yet running it for ~
92 ~D times resulted in the allocation of ~
93 ~D bytes~:[ (~,3F per run)~;~].~@:>"
94 form yes
/no times consed-bytes
95 (zerop consed-bytes
) (float (/ consed-bytes times
))))
96 (values before after
)))
98 (defparameter +times
+ 10000)
100 (defmacro assert-no-consing
(form &optional
(times '+times
+))
101 `(check-consing nil
',form
(lambda () ,form
) ,times
))
103 (defmacro assert-consing
(form &optional
(times '+times
+))
104 `(check-consing t
',form
(lambda () ,form
) ,times
))
106 (defun file-compile (toplevel-forms &key load
)
107 (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
108 (fasl (compile-file-pathname lisp
)))
111 (with-open-file (f lisp
:direction
:output
)
112 (if (stringp toplevel-forms
)
113 (write-line toplevel-forms f
)
114 (dolist (form toplevel-forms
)
116 (multiple-value-bind (fasl warn fail
) (compile-file lisp
)
120 (ignore-errors (delete-file lisp
))
121 (ignore-errors (delete-file fasl
)))))
123 ;; Pretty horrible, but does the job
124 (defun count-full-calls (name function
)
125 (let ((code (with-output-to-string (s)
126 (let ((*print-right-margin
* 120))
127 (disassemble function
:stream s
))))
129 (with-input-from-string (s code
)
130 (loop for line
= (read-line s nil nil
)
132 when
(and (search name line
)
133 (search "FDEFN" line
))