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 (:import-from
#:sb-c
#:*compile-component-hook
*)
21 #:compiler-derived-type
25 #:find-anonymous-callees
34 (unless (fboundp 'compiler-derived-type
)
35 (defknown compiler-derived-type
(t) (values t t
) (flushable))
36 (deftransform compiler-derived-type
((x) * * :node node
)
37 (sb-c::delay-ir1-transform node
:ir1-phases
)
38 `(values ',(type-specifier (sb-c::lvar-type x
)) t
))
39 (defun compiler-derived-type (x)
43 ;;; New tests should use INSPECT-IR or ASM-SEARCH rather than FIND-NAMED-CALLEES
44 ;;; unless you are 100% certain that there will be an fdefn of the given name.
45 ;;; (negative assertions may yield falsely passing tests)
46 (defun asm-search (expect lambda
)
47 (let* ((code (etypecase lambda
48 (cons (test-util:checked-compile lambda
))
51 (with-output-to-string (s)
52 (let ((sb-disassem:*disassem-location-column-width
* 0)
55 (loop for line in
(test-util:split-string disassembly
#\newline
)
56 when
(and (search expect line
)
57 (not (search "; Origin" line
)))
60 (defun inspect-ir (form fun
&rest checked-compile-args
)
61 (let ((*compile-component-hook
* fun
))
62 (apply #'test-util
:checked-compile form checked-compile-args
)))
64 (defun ir1-named-calls (lambda-expression &optional
(full t
))
65 (declare (ignorable lambda-expression full
))
67 (throw 'test-util
::skip-test t
)
74 (sb-c::do-blocks
(block component
)
75 (sb-c::do-nodes
(node nil block
)
76 (when (and (sb-c::basic-combination-p node
)
78 (eq (sb-c::basic-combination-info node
) :full
)
80 (push (sb-c::combination-fun-debug-name node
) calls
))))))))
81 (values calls compiled-fun
)))
83 ;;; For any call that passes a global constant funarg - as in (FOO #'EQ) -
84 ;;; return the name of the caller and the names of all such funargs.
85 (defun ir1-funargs (lambda-expression)
86 (declare (ignorable lambda-expression
))
88 (throw 'test-util
::skip-test t
)
95 (sb-c::do-blocks
(block component
)
96 (sb-c::do-nodes
(node nil block
)
97 (when (and (sb-c::basic-combination-p node
)
98 (eq (sb-c::basic-combination-info node
) :full
))
101 (lambda (arg &aux
(uses (sb-c::lvar-uses arg
)))
102 (when (sb-c::ref-p uses
)
103 (let ((leaf (sb-c::ref-leaf uses
)))
104 (when (and (sb-c::global-var-p leaf
)
105 (eq (sb-c::global-var-kind leaf
) :global-function
))
106 (list (sb-c::leaf-source-name leaf
))))))
107 (sb-c::combination-args node
))))
109 (push (cons (sb-c::combination-fun-debug-name node
) filtered
)
111 (values calls compiled-fun
)))
113 (when (member :linkage-space sb-impl
:+internal-features
+) ; for below
114 (pushnew :linkage-space
*features
*))
116 (defun find-named-callees (fun &key
(name nil namep
))
117 (let ((code (fun-code-header (%fun-fun fun
))))
119 (loop for index in
(sb-c:unpack-code-fixup-locs
(sb-vm::%code-fixups code
))
120 for this
= (sb-vm::linkage-addr-
>name index
:index
)
121 when
(or (not namep
) (equal this name
))
124 (sb-int:binding
* (((start count
) (sb-kernel:code-header-fdefn-range code
)))
125 (loop for i from start repeat count
126 for c
= (code-header-ref code i
)
127 when
(or (not namep
) (equal name
(sb-kernel:fdefn-name c
)))
128 collect
(sb-kernel:fdefn-name c
)))))
130 (defun find-anonymous-callees (fun &key
(type 'function
))
131 (let ((code (fun-code-header (%fun-fun fun
))))
132 (loop for i from sb-vm
:code-constants-offset below
(code-header-words code
)
133 for fun
= (code-header-ref code i
)
134 when
(typep fun type
)
137 ;;; Return a subset of the code constants for FUN's code but excluding
138 ;;; constants that are present on behalf of %SIMPLE-FUN-foo accessors.
139 (defun find-code-constants (fun &key
(type t
))
140 (let ((code (fun-code-header (%fun-fun fun
))))
141 (loop for i from sb-vm
:code-constants-offset
142 below
(code-header-words code
)
143 for c
= (code-header-ref code i
)
144 for value
= (if (= (widetag-of c
) sb-vm
:value-cell-widetag
)
147 when
(and (not (eql value
0)) ;; alignment zeros
151 (defun collect-consing-stats (thunk times
)
152 (declare (type function thunk
))
153 (declare (type fixnum times
))
154 #+(and sb-thread gencgc
) (sb-vm::close-thread-alloc-region
)
155 (setf sb-int
:*n-bytes-freed-or-purified
* 0)
156 (let ((before (sb-ext:get-bytes-consed
)))
159 (values before
(sb-ext:get-bytes-consed
))))
161 (defun check-consing (yes/no form thunk times
)
162 (multiple-value-bind (before after
)
163 (collect-consing-stats thunk times
)
164 (let* ((consed-bytes (- after before
))
165 (bytes-per-iteration (float (/ consed-bytes times
))))
167 (funcall (if yes
/no
#'not
#'identity
)
168 ;; If allocation really happened, it can't have been less than one cons cell
169 ;; per iteration (unless the test is nondeterministic - but in that case
170 ;; we can't really use this strategy anyway). So consider it to have consed
171 ;; nothing if the fraction is too small.
172 (< bytes-per-iteration
(* 2 sb-vm
:n-word-bytes
)))
175 "~@<Expected the form ~
177 ~:[NOT to cons~;to cons~], yet running it for ~
178 ~D times resulted in the allocation of ~
179 ~D bytes~:[ (~,3F per run)~;~].~@:>"
180 form yes
/no times consed-bytes
181 (zerop consed-bytes
) bytes-per-iteration
))
182 (values before after
)))
184 (defparameter +times
+ 10000)
186 (defmacro assert-no-consing
(form &optional
(times '+times
+))
187 `(check-consing nil
',form
(lambda () ,form
) ,times
))
189 (defmacro assert-consing
(form &optional
(times '+times
+))
190 `(check-consing t
',form
(lambda () ,form
) ,times
))
192 (defun file-compile (toplevel-forms &key load
195 (let* ((lisp (test-util:scratch-file-name
"lisp"))
196 (fasl (compile-file-pathname lisp
))
197 (error-stream (make-string-output-stream)))
200 (with-open-file (f lisp
:direction
:output
)
201 (if (stringp toplevel-forms
)
202 (write-line toplevel-forms f
)
203 (dolist (form toplevel-forms
)
205 ;; Preserve all referenced callees. This has no effect on semantics
206 (sb-int:encapsulate
'sb-int
:permanent-fname-p
'test-shim
#'sb-int
:constantly-nil
)
207 (multiple-value-bind (fasl warn fail
)
208 (let ((*error-output
* error-stream
))
209 (compile-file lisp
:print nil
:verbose nil
210 :block-compile block-compile
))
213 (funcall before-load
))
214 (let ((*error-output
* error-stream
))
215 (load fasl
:print nil
:verbose nil
)))
216 (values warn fail error-stream
)))
217 (sb-int:unencapsulate
'sb-int
:permanent-fname-p
'test-shim
)
218 (ignore-errors (delete-file lisp
))
219 (ignore-errors (delete-file fasl
)))))
221 ;;; TODO: this would be better done as LIST-FULL-CALLS so that you could
222 ;;; make an assertion that the list EQUALs something in particular.
223 ;;; Negative assertions (essentially "count = 0") are silently susceptible
224 ;;; to spelling mistakes or a change in how we name nodes.
225 (defun count-full-calls (function-name lambda-expression
)
226 (declare (ignorable function-name lambda-expression
))
228 (throw 'test-util
::skip-test t
)
234 (sb-c::do-blocks
(block component
)
235 (sb-c::do-nodes
(node nil block
)
236 (when (and (sb-c::basic-combination-p node
)
237 (eq (sb-c::basic-combination-info node
) :full
)
238 (equal (sb-c::combination-fun-debug-name node
)
243 (defun disassembly-lines (fun)
244 ;; FIXME: I don't remember what this override of the hook is for.
245 (sb-int:encapsulate
'sb-disassem
::add-debugging-hooks
'test
246 (lambda (f &rest args
) (declare (ignore f args
))))
248 (mapcar (lambda (x) (string-left-trim " ;" x
))
250 (test-util:split-string
251 (with-output-to-string (s)
252 (let ((sb-disassem:*disassem-location-column-width
* 0)
253 (*print-pretty
* nil
))
254 (disassemble fun
:stream s
)))
256 (sb-int:unencapsulate
'sb-disassem
::add-debugging-hooks
'test
)))