-
Notifications
You must be signed in to change notification settings - Fork 0
/
compiler-test-util.lisp
137 lines (123 loc) · 5.22 KB
/
compiler-test-util.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
;;;; Utilities for verifying features of compiled code
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(defpackage :compiler-test-util
(:nicknames :ctu)
(:use :cl :sb-c :sb-kernel)
(:export #:assert-consing
#:assert-no-consing
#:compiler-derived-type
#:count-full-calls
#:find-code-constants
#:find-named-callees
#:find-anonymous-callees
#:file-compile))
(cl:in-package :ctu)
(unless (fboundp 'compiler-derived-type)
(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))
(defun compiler-derived-type (x)
(declare (ignore x))
(values t nil)))
(defun find-named-callees (fun &key (type t) (name nil namep))
(let ((code (fun-code-header (%fun-fun fun))))
(loop for i from sb-vm:code-constants-offset below (code-header-words code)
for c = (code-header-ref code i)
when (and (typep c 'sb-impl::fdefn)
(let ((fun (sb-impl::fdefn-fun c)))
(and (typep fun type)
(or (not namep)
(equal name (sb-impl::fdefn-name c))))))
collect (sb-impl::fdefn-fun c))))
(defun find-anonymous-callees (fun &key (type 'function))
(let ((code (fun-code-header (%fun-fun fun))))
(loop for i from sb-vm:code-constants-offset below (code-header-words code)
for fun = (code-header-ref code i)
when (typep fun type)
collect fun)))
(defun find-code-constants (fun &key (type t))
(let ((code (fun-code-header (%fun-fun fun))))
(loop for i from sb-vm:code-constants-offset below (code-header-words code)
for c = (code-header-ref code i)
for value = (if (= (widetag-of c) sb-vm:value-cell-widetag)
(value-cell-ref c)
c)
when (typep value type)
collect value)))
(defun collect-consing-stats (thunk times)
(declare (type function thunk))
(declare (type fixnum times))
#+(and sb-thread gencgc)
(sb-vm::close-current-gc-region)
(setf sb-int:*n-bytes-freed-or-purified* 0)
(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))
(error-stream (make-string-output-stream)))
(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)
(let ((*error-output* error-stream))
(compile-file lisp :print nil :verbose nil))
(when load
(let ((*error-output* error-stream))
(load fasl :print nil :verbose nil)))
(values warn fail error-stream)))
(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)
(let ((*print-right-margin* 120))
(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 "FDEFN" line))
do (incf n)))
n))