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-named-callees))
  22
  23 (cl:in-package :ctu)
  24
  25 (unless (fboundp 'compiler-derived-type)
  26   (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
  27   (deftransform compiler-derived-type ((x) * * :node node)
  28     (sb-c::delay-ir1-transform node :optimize)
  29     `(values ',(type-specifier (sb-c::lvar-type x)) t))
  30   (defun compiler-derived-type (x)
  31     (declare (ignore x))
  32     (values t nil)))
  33
  34 (defun find-value-cell-values (fun)
  35   (let ((code (fun-code-header (%fun-fun fun))))
  36     (loop for i from sb-vm::code-constants-offset below (get-header-data code)
  37           for c = (code-header-ref code i)
  38           when (= sb-vm::value-cell-header-widetag (widetag-of c))
  39           collect (sb-vm::value-cell-ref c))))
  40
  41 (defun find-named-callees (fun &key (type t) (name nil namep))
  42   (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
  43     (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
  44           for c = (sb-kernel:code-header-ref code i)
  45           when (and (typep c 'sb-impl::fdefn)
  46                     (let ((fun (sb-impl::fdefn-fun c)))
  47                       (and (typep fun type)
  48                            (or (not namep)
  49                                (equal name (sb-impl::fdefn-name c))))))
  50           collect (sb-impl::fdefn-fun c))))
  51
  52 (defmacro assert-no-consing (form &optional times)
  53   `(%assert-no-consing (lambda () ,form) ,times))
  54 (defun %assert-no-consing (thunk &optional times)
  55   (let ((before (sb-ext:get-bytes-consed))
  56         (times (or times 10000)))
  57     (declare (type (integer 1 *) times))
  58     (dotimes (i times)
  59       (funcall thunk))
  60     (assert (< (- (sb-ext:get-bytes-consed) before) times))))
  61
  62 (defmacro assert-consing (form &optional times)
  63   `(%assert-consing (lambda () ,form) ,times))
  64 (defun %assert-consing (thunk &optional times)
  65   (let ((before (sb-ext:get-bytes-consed))
  66         (times (or times 10000)))
  67     (declare (type (integer 1 *) times))
  68     (dotimes (i times)
  69       (funcall thunk))
  70     (assert (not (< (- (sb-ext:get-bytes-consed) before) times)))))