Really restore clisp cross-compilation.
[sbcl.git] / tests / compiler-test-util.lisp
1 ;;;; Utilities for verifying features of compiled code
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (defpackage :compiler-test-util
15   (:nicknames :ctu)
16   (:use :cl :sb-c :sb-kernel)
17   (:export #:assert-consing
18            #:assert-no-consing
19            #:compiler-derived-type
20            #:count-full-calls
21            #:find-value-cell-values
22            #:find-code-constants
23            #:find-named-callees
24            #:file-compile))
25
26 (cl:in-package :ctu)
27
28 (unless (fboundp 'compiler-derived-type)
29   (defknown compiler-derived-type (t) (values t t) (flushable))
30   (deftransform compiler-derived-type ((x) * * :node node)
31     (sb-c::delay-ir1-transform node :optimize)
32     `(values ',(type-specifier (sb-c::lvar-type x)) t))
33   (defun compiler-derived-type (x)
34     (declare (ignore x))
35     (values t nil)))
36
37 (defun find-value-cell-values (fun)
38   (let ((code (fun-code-header (%fun-fun fun))))
39     (loop for i from sb-vm::code-constants-offset below (get-header-data code)
40           for c = (code-header-ref code i)
41           when (= sb-vm::value-cell-header-widetag (widetag-of c))
42           collect (sb-vm::value-cell-ref c))))
43
44 (defun find-named-callees (fun &key (type t) (name nil namep))
45   (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
46     (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
47           for c = (sb-kernel:code-header-ref code i)
48           when (and (typep c 'sb-impl::fdefn)
49                     (let ((fun (sb-impl::fdefn-fun c)))
50                       (and (typep fun type)
51                            (or (not namep)
52                                (equal name (sb-impl::fdefn-name c))))))
53           collect (sb-impl::fdefn-fun c))))
54
55 (defun find-code-constants (fun &key (type t))
56   (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
57     (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
58           for c = (sb-kernel:code-header-ref code i)
59           when (typep c type)
60           collect c)))
61
62 (defun collect-consing-stats (thunk times)
63   (declare (type function thunk))
64   (declare (type fixnum times))
65   (let ((before (sb-ext:get-bytes-consed)))
66     (dotimes (i times)
67       (funcall thunk))
68     (values before (sb-ext:get-bytes-consed))))
69
70 (defun check-consing (yes/no form thunk times)
71   (multiple-value-bind (before after)
72       (collect-consing-stats thunk times)
73     (let ((consed-bytes (- after before)))
74       (assert (funcall (if yes/no #'not #'identity)
75                        ;; I do not know why we do this comparasion,
76                        ;; the original code did, so I let it
77                        ;; in. Perhaps to prevent losage on GC
78                        ;; fluctuations, or something. --TCR.
79                        (< consed-bytes times))
80               ()
81               "~@<Expected the form ~
82                       ~4I~@:_~A ~0I~@:_~
83                   ~:[NOT to cons~;to cons~], yet running it for ~
84                   ~D times resulted in the allocation of ~
85                   ~D bytes~:[ (~,3F per run)~;~].~@:>"
86               form yes/no times consed-bytes
87               (zerop consed-bytes) (float (/ consed-bytes times))))
88     (values before after)))
89
90 (defparameter +times+ 10000)
91
92 (defmacro assert-no-consing (form &optional (times '+times+))
93   `(check-consing nil ',form (lambda () ,form) ,times))
94
95 (defmacro assert-consing (form &optional (times '+times+))
96   `(check-consing t ',form (lambda () ,form) ,times))
97
98 (defun file-compile (toplevel-forms &key load)
99   (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
100          (fasl (compile-file-pathname lisp)))
101     (unwind-protect
102          (progn
103            (with-open-file (f lisp :direction :output)
104              (if (stringp toplevel-forms)
105                  (write-line toplevel-forms f)
106                  (dolist (form toplevel-forms)
107                    (prin1 form f))))
108            (multiple-value-bind (fasl warn fail) (compile-file lisp)
109              (when load
110                (load fasl))
111              (values warn fail)))
112       (ignore-errors (delete-file lisp))
113       (ignore-errors (delete-file fasl)))))
114
115 ;; Pretty horrible, but does the job
116 (defun count-full-calls (name function)
117   (let ((code (with-output-to-string (s)
118                 (disassemble function :stream s)))
119         (n 0))
120     (with-input-from-string (s code)
121       (loop for line = (read-line s nil nil)
122             while line
123             when (and (search name line)
124                       (search "#<FDEFINITION" line))
125             do (incf n)))
126     n))