Fix contrib building on mingw.

[sbcl.git] / tests / compiler-test-util.lisp

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index 25a6ed4..352db70 100644 (file)
--- a/tests/compiler-test-util.lisp
+++ b/tests/compiler-test-util.lisp
@@ -17,14 +17,16 @@
   (:export #:assert-consing
            #:assert-no-consing
            #:compiler-derived-type
+           #:count-full-calls
            #:find-value-cell-values
            #:find-code-constants
-           #:find-named-callees))
+           #:find-named-callees
+           #:file-compile))
 
 (cl:in-package :ctu)
 
 (unless (fboundp 'compiler-derived-type)
-  (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
+  (defknown compiler-derived-type (t) (values t t) (flushable))
   (deftransform compiler-derived-type ((x) * * :node node)
     (sb-c::delay-ir1-transform node :optimize)
     `(values ',(type-specifier (sb-c::lvar-type x)) t))
@@ -57,22 +59,68 @@
           when (typep c type)
           collect c)))
 
-(defmacro assert-no-consing (form &optional times)
-  `(%assert-no-consing (lambda () ,form) ,times))
-(defun %assert-no-consing (thunk &optional times)
-  (let ((before (sb-ext:get-bytes-consed))
-        (times (or times 10000)))
-    (declare (type (integer 1 *) times))
+(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))
-    (assert (< (- (sb-ext:get-bytes-consed) before) times))))
+    (values before (sb-ext:get-bytes-consed))))
 
-(defmacro assert-consing (form &optional times)
-  `(%assert-consing (lambda () ,form) ,times))
-(defun %assert-consing (thunk &optional times)
-  (let ((before (sb-ext:get-bytes-consed))
-        (times (or times 10000)))
-    (declare (type (integer 1 *) times))
-    (dotimes (i times)
-      (funcall thunk))
-    (assert (not (< (- (sb-ext:get-bytes-consed) before) times)))))
+(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)
+             (if (stringp toplevel-forms)
+                 (write-line toplevel-forms f)
+                 (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)))))
+
+;; Pretty horrible, but does the job
+(defun count-full-calls (name function)
+  (let ((code (with-output-to-string (s)
+                (disassemble function :stream s)))
+        (n 0))
+    (with-input-from-string (s code)
+      (loop for line = (read-line s nil nil)
+            while line
+            when (and (search name line)
+                      (search "#<FDEFINITION" line))
+            do (incf n)))
+    n))