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 (defun collect-consing-stats (thunk times)
61 (declare (type function thunk))
62 (declare (type fixnum times))
63 (let ((before (sb-ext:get-bytes-consed)))
66 (values before (sb-ext:get-bytes-consed))))
68 (defun check-consing (yes/no form thunk times)
69 (multiple-value-bind (before after)
70 (collect-consing-stats thunk times)
71 (let ((consed-bytes (- after before)))
72 (assert (funcall (if yes/no #'not #'identity)
73 ;; I do not know why we do this comparasion,
74 ;; the original code did, so I let it
75 ;; in. Perhaps to prevent losage on GC
76 ;; fluctuations, or something. --TCR.
77 (< consed-bytes times))
79 "~@<Expected the form ~
81 ~:[NOT to cons~;to cons~], yet running it for ~
82 ~D times resulted in the allocation of ~
83 ~D bytes~:[ (~,3F per run)~;~].~@:>"
84 form yes/no times consed-bytes
85 (zerop consed-bytes) (float (/ consed-bytes times))))
86 (values before after)))
88 (defparameter +times+ 10000)
90 (defmacro assert-no-consing (form &optional (times '+times+))
91 `(check-consing nil ',form (lambda () ,form) ,times))
93 (defmacro assert-consing (form &optional (times '+times+))
94 `(check-consing t ',form (lambda () ,form) ,times))