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-code-constants
  22            #:find-named-callees
  23            #:find-anonymous-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-named-callees (fun &key (type t) (name nil namep))
  38   (let ((code (fun-code-header (%fun-fun fun))))
  39     (loop for i from sb-vm:code-constants-offset below (code-header-words code)
  40           for c = (code-header-ref code i)
  41           when (and (typep c 'sb-impl::fdefn)
  42                     (let ((fun (sb-impl::fdefn-fun c)))
  43                       (and (typep fun type)
  44                            (or (not namep)
  45                                (equal name (sb-impl::fdefn-name c))))))
  46           collect (sb-impl::fdefn-fun c))))
  47
  48 (defun find-anonymous-callees (fun &key (type 'function))
  49   (let ((code (fun-code-header (%fun-fun fun))))
  50     (loop for i from sb-vm:code-constants-offset below (code-header-words code)
  51           for fun = (code-header-ref code i)
  52           when (typep fun type)
  53           collect fun)))
  54
  55 (defun find-code-constants (fun &key (type t))
  56   (let ((code (fun-code-header (%fun-fun fun))))
  57     (loop for i from sb-vm:code-constants-offset below (code-header-words code)
  58           for c = (code-header-ref code i)
  59           for value = (if (= (widetag-of c) sb-vm:value-cell-widetag)
  60                           (value-cell-ref c)
  61                           c)
  62           when (typep value type)
  63           collect value)))
  64
  65 (defun collect-consing-stats (thunk times)
  66   (declare (type function thunk))
  67   (declare (type fixnum times))
  68   (let ((before (sb-ext:get-bytes-consed)))
  69     (dotimes (i times)
  70       (funcall thunk))
  71     (values before (sb-ext:get-bytes-consed))))
  72
  73 (defun check-consing (yes/no form thunk times)
  74   (multiple-value-bind (before after)
  75       (collect-consing-stats thunk times)
  76     (let ((consed-bytes (- after before)))
  77       (assert (funcall (if yes/no #'not #'identity)
  78                        ;; I do not know why we do this comparasion,
  79                        ;; the original code did, so I let it
  80                        ;; in. Perhaps to prevent losage on GC
  81                        ;; fluctuations, or something. --TCR.
  82                        (< consed-bytes times))
  83               ()
  84               "~@<Expected the form ~
  85                       ~4I~@:_~A ~0I~@:_~
  86                   ~:[NOT to cons~;to cons~], yet running it for ~
  87                   ~D times resulted in the allocation of ~
  88                   ~D bytes~:[ (~,3F per run)~;~].~@:>"
  89               form yes/no times consed-bytes
  90               (zerop consed-bytes) (float (/ consed-bytes times))))
  91     (values before after)))
  92
  93 (defparameter +times+ 10000)
  94
  95 (defmacro assert-no-consing (form &optional (times '+times+))
  96   `(check-consing nil ',form (lambda () ,form) ,times))
  97
  98 (defmacro assert-consing (form &optional (times '+times+))
  99   `(check-consing t ',form (lambda () ,form) ,times))
 100
 101 (defun file-compile (toplevel-forms &key load)
 102   (let* ((lisp (merge-pathnames "file-compile-tmp.lisp"))
 103          (fasl (compile-file-pathname lisp))
 104          (error-stream (make-string-output-stream)))
 105     (unwind-protect
 106          (progn
 107            (with-open-file (f lisp :direction :output)
 108              (if (stringp toplevel-forms)
 109                  (write-line toplevel-forms f)
 110                  (dolist (form toplevel-forms)
 111                    (prin1 form f))))
 112            (multiple-value-bind (fasl warn fail)
 113                (let ((*error-output* error-stream))
 114                  (compile-file lisp :print nil :verbose nil))
 115              (when load
 116                (let ((*error-output* error-stream))
 117                  (load fasl :print nil :verbose nil)))
 118              (values warn fail error-stream)))
 119       (ignore-errors (delete-file lisp))
 120       (ignore-errors (delete-file fasl)))))
 121
 122 ;; Pretty horrible, but does the job
 123 (defun count-full-calls (name function)
 124   (let ((code (with-output-to-string (s)
 125                 (let ((*print-right-margin* 120))
 126                   (disassemble function :stream s))))
 127         (n 0))
 128     (with-input-from-string (s code)
 129       (loop for line = (read-line s nil nil)
 130             while line
 131             when (and (search name line)
 132                       (search "FDEFN" line))
 133             do (incf n)))
 134     n))