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