(: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))
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))