(defpackage :compiler-test-util
(:nicknames :ctu)
(:use :cl :sb-c :sb-kernel)
- (:export #:compiler-derived-type
+ (:export #:assert-consing
+ #:assert-no-consing
+ #:compiler-derived-type
#:find-value-cell-values
+ #:find-code-constants
#:find-named-callees))
(cl:in-package :ctu)
(or (not namep)
(equal name (sb-impl::fdefn-name c))))))
collect (sb-impl::fdefn-fun c))))
+
+(defun find-code-constants (fun &key (type t))
+ (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
+ (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+ for c = (sb-kernel:code-header-ref code i)
+ when (typep c type)
+ collect c)))
+
+(defun collect-consing-stats (thunk times)
+ (declare (type function thunk))
+ (declare (type fixnum times))
+ (let ((before (sb-ext:get-bytes-consed)))
+ (dotimes (i times)
+ (funcall thunk))
+ (values before (sb-ext:get-bytes-consed))))
+
+(defun check-consing (yes/no form thunk times)
+ (multiple-value-bind (before after)
+ (collect-consing-stats thunk times)
+ (let ((consed-bytes (- after before)))
+ (assert (funcall (if yes/no #'not #'identity)
+ ;; I do not know why we do this comparasion,
+ ;; the original code did, so I let it
+ ;; in. Perhaps to prevent losage on GC
+ ;; fluctuations, or something. --TCR.
+ (< consed-bytes times))
+ ()
+ "~@<Expected the form ~
+ ~4I~@:_~A ~0I~@:_~
+ ~:[NOT to cons~;to cons~], yet running it for ~
+ ~D times resulted in the allocation of ~
+ ~D bytes~:[ (~,3F per run)~;~].~@:>"
+ form yes/no times consed-bytes
+ (zerop consed-bytes) (float (/ consed-bytes times))))
+ (values before after)))
+
+(defparameter +times+ 10000)
+
+(defmacro assert-no-consing (form &optional (times '+times+))
+ `(check-consing nil ',form (lambda () ,form) ,times))
+
+(defmacro assert-consing (form &optional (times '+times+))
+ `(check-consing t ',form (lambda () ,form) ,times))