X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler-test-util.lisp;h=938af5cf19dcaededbd4aafa899360a49cac7dae;hb=ee5629ee974ee8ce7a1cb245a99e94f8943ffd90;hp=1ed4fa6d6af3e2eac531c8320f949fcdb456fc7e;hpb=485944b1d04b8f3381a04bc6291bc2e667442e45;p=sbcl.git

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index 1ed4fa6..938af5c 100644
--- a/tests/compiler-test-util.lisp
+++ b/tests/compiler-test-util.lisp
@@ -14,9 +14,13 @@
 (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-named-callees))
+           #:find-code-constants
+           #:find-named-callees
+           #:file-compile))
 
 (cl:in-package :ctu)
 
@@ -46,3 +50,61 @@
                            (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))
+
+(defun file-compile (toplevel-forms &key load)
+  (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
+         (fasl (compile-file-pathname lisp)))
+    (unwind-protect
+         (progn
+           (with-open-file (f lisp :direction :output)
+             (dolist (form toplevel-forms)
+               (prin1 form f)))
+           (multiple-value-bind (fasl warn fail) (compile-file lisp)
+             (when load
+               (load fasl))
+             (values warn fail)))
+      (ignore-errors (delete-file lisp))
+      (ignore-errors (delete-file fasl)))))