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   (:import-from #:sb-c #:*compile-component-hook*)
  18   (:export #:asm-search
  19            #:assert-consing
  20            #:assert-no-consing
  21            #:compiler-derived-type
  22            #:count-full-calls
  23            #:find-code-constants
  24            #:find-named-callees
  25            #:find-anonymous-callees
  26            #:file-compile
  27            #:inspect-ir
  28            #:ir1-named-calls
  29            #:ir1-funargs
  30            #:disassembly-lines))
  31
  32 (cl:in-package :ctu)
  33
  34 (unless (fboundp 'compiler-derived-type)
  35   (defknown compiler-derived-type (t) (values t t) (flushable))
  36   (deftransform compiler-derived-type ((x) * * :node node)
  37     (sb-c::delay-ir1-transform node :ir1-phases)
  38     `(values ',(type-specifier (sb-c::lvar-type x)) t))
  39   (defun compiler-derived-type (x)
  40     (declare (ignore x))
  41     (values t nil)))
  42
  43 ;;; New tests should use INSPECT-IR or ASM-SEARCH rather than FIND-NAMED-CALLEES
  44 ;;; unless you are 100% certain that there will be an fdefn of the given name.
  45 ;;; (negative assertions may yield falsely passing tests)
  46 (defun asm-search (expect lambda)
  47   (let* ((code (etypecase lambda
  48                  (cons (test-util:checked-compile lambda))
  49                  (function lambda)))
  50          (disassembly
  51           (with-output-to-string (s)
  52             (let ((sb-disassem:*disassem-location-column-width* 0)
  53                   (*print-pretty* nil))
  54               (sb-c:dis code s)))))
  55     (loop for line in (test-util:split-string disassembly #\newline)
  56           when (and (search expect line)
  57                     (not (search "; Origin" line)))
  58           collect line)))
  59
  60 (defun inspect-ir (form fun &rest checked-compile-args)
  61   (let ((*compile-component-hook* fun))
  62     (apply #'test-util:checked-compile form checked-compile-args)))
  63
  64 (defun ir1-named-calls (lambda-expression &optional (full t))
  65   (declare (ignorable lambda-expression full))
  66   #-sb-devel
  67   (throw 'test-util::skip-test t)
  68   #+sb-devel
  69   (let* ((calls)
  70          (compiled-fun
  71            (inspect-ir
  72             lambda-expression
  73             (lambda (component)
  74               (sb-c::do-blocks (block component)
  75                 (sb-c::do-nodes (node nil block)
  76                   (when (and (sb-c::basic-combination-p node)
  77                              (if full
  78                                  (eq (sb-c::basic-combination-info node) :full)
  79                                  t))
  80                     (push (sb-c::combination-fun-debug-name node) calls))))))))
  81     (values calls compiled-fun)))
  82
  83 ;;; For any call that passes a global constant funarg - as in (FOO #'EQ) -
  84 ;;; return the name of the caller and the names of all such funargs.
  85 (defun ir1-funargs (lambda-expression)
  86   (declare (ignorable lambda-expression))
  87   #-sb-devel
  88   (throw 'test-util::skip-test t)
  89   #+sb-devel
  90   (let* ((calls)
  91          (compiled-fun
  92            (inspect-ir
  93             lambda-expression
  94             (lambda (component)
  95               (sb-c::do-blocks (block component)
  96                 (sb-c::do-nodes (node nil block)
  97                   (when (and (sb-c::basic-combination-p node)
  98                              (eq (sb-c::basic-combination-info node) :full))
  99                     (let ((filtered
 100                             (mapcan
 101                              (lambda (arg &aux (uses (sb-c::lvar-uses arg)))
 102                                (when (sb-c::ref-p uses)
 103                                  (let ((leaf (sb-c::ref-leaf uses)))
 104                                    (when (and (sb-c::global-var-p leaf)
 105                                               (eq (sb-c::global-var-kind leaf) :global-function))
 106                                      (list (sb-c::leaf-source-name leaf))))))
 107                              (sb-c::combination-args node))))
 108                       (when filtered
 109                         (push (cons (sb-c::combination-fun-debug-name node) filtered)
 110                               calls))))))))))
 111     (values calls compiled-fun)))
 112
 113 (defun find-named-callees (fun &key (name nil namep))
 114   (sb-int:binding* ((code (fun-code-header (%fun-fun fun)))
 115                     ((start count) (sb-kernel:code-header-fdefn-range code)))
 116     (loop for i from start repeat count
 117           for c = (code-header-ref code i)
 118           when (or (not namep) (equal name (sb-kernel:fdefn-name c)))
 119           collect (sb-kernel:fdefn-fun c))))
 120
 121 (defun find-anonymous-callees (fun &key (type 'function))
 122   (let ((code (fun-code-header (%fun-fun fun))))
 123     (loop for i from sb-vm:code-constants-offset below (code-header-words code)
 124           for fun = (code-header-ref code i)
 125           when (typep fun type)
 126           collect fun)))
 127
 128 ;;; Return a subset of the code constants for FUN's code but excluding
 129 ;;; constants that are present on behalf of %SIMPLE-FUN-foo accessors.
 130 (defun find-code-constants (fun &key (type t))
 131   (let ((code (fun-code-header (%fun-fun fun))))
 132     (loop for i from (+ sb-vm:code-constants-offset
 133                         (* (code-n-entries code) sb-vm:code-slots-per-simple-fun))
 134           below (code-header-words code)
 135           for c = (code-header-ref code i)
 136           for value = (if (= (widetag-of c) sb-vm:value-cell-widetag)
 137                           (value-cell-ref c)
 138                           c)
 139           when (and (not (eql value 0)) ;; alignment zeros
 140                     (typep value type))
 141           collect value)))
 142
 143 (defun collect-consing-stats (thunk times)
 144   (declare (type function thunk))
 145   (declare (type fixnum times))
 146   #+(and sb-thread gencgc) (sb-vm::close-thread-alloc-region)
 147   (setf sb-int:*n-bytes-freed-or-purified* 0)
 148   (let ((before (sb-ext:get-bytes-consed)))
 149     (dotimes (i times)
 150       (funcall thunk))
 151     (values before (sb-ext:get-bytes-consed))))
 152
 153 (defun check-consing (yes/no form thunk times)
 154   (multiple-value-bind (before after)
 155       (collect-consing-stats thunk times)
 156     (let* ((consed-bytes (- after before))
 157            (bytes-per-iteration (float (/ consed-bytes times))))
 158       (assert (progn
 159                 (funcall (if yes/no #'not #'identity)
 160                          ;; If allocation really happened, it can't have been less than one cons cell
 161                          ;; per iteration (unless the test is nondeterministic - but in that case
 162                          ;; we can't really use this strategy anyway). So consider it to have consed
 163                          ;; nothing if the fraction is too small.
 164                          (< bytes-per-iteration (* 2 sb-vm:n-word-bytes)))
 165                 #+gc-stress t)
 166               ()
 167               "~@<Expected the form ~
 168                       ~4I~@:_~A ~0I~@:_~
 169                   ~:[NOT to cons~;to cons~], yet running it for ~
 170                   ~D times resulted in the allocation of ~
 171                   ~D bytes~:[ (~,3F per run)~;~].~@:>"
 172               form yes/no times consed-bytes
 173               (zerop consed-bytes) bytes-per-iteration))
 174     (values before after)))
 175
 176 (defparameter +times+ 10000)
 177
 178 (defmacro assert-no-consing (form &optional (times '+times+))
 179   `(check-consing nil ',form (lambda () ,form) ,times))
 180
 181 (defmacro assert-consing (form &optional (times '+times+))
 182   `(check-consing t ',form (lambda () ,form) ,times))
 183
 184 (defun file-compile (toplevel-forms &key load
 185                                          before-load
 186                                          block-compile)
 187   (let* ((lisp (test-util:scratch-file-name "lisp"))
 188          (fasl (compile-file-pathname lisp))
 189          (error-stream (make-string-output-stream)))
 190     (unwind-protect
 191          (progn
 192            (with-open-file (f lisp :direction :output)
 193              (if (stringp toplevel-forms)
 194                  (write-line toplevel-forms f)
 195                  (dolist (form toplevel-forms)
 196                    (prin1 form f))))
 197            (multiple-value-bind (fasl warn fail)
 198                (let ((*error-output* error-stream))
 199                  (compile-file lisp :print nil :verbose nil
 200                                     :block-compile block-compile))
 201              (when load
 202                (when before-load
 203                  (funcall before-load))
 204                (let ((*error-output* error-stream))
 205                  (load fasl :print nil :verbose nil)))
 206              (values warn fail error-stream)))
 207       (ignore-errors (delete-file lisp))
 208       (ignore-errors (delete-file fasl)))))
 209
 210 ;;; TODO: this would be better done as LIST-FULL-CALLS so that you could
 211 ;;; make an assertion that the list EQUALs something in particular.
 212 ;;; Negative assertions (essentially "count = 0") are silently susceptible
 213 ;;; to spelling mistakes or a change in how we name nodes.
 214 (defun count-full-calls (function-name lambda-expression)
 215   (declare (ignorable function-name lambda-expression))
 216   #-sb-devel
 217   (throw 'test-util::skip-test t)
 218   #+sb-devel
 219   (let ((n 0))
 220     (inspect-ir
 221      lambda-expression
 222      (lambda (component)
 223        (sb-c::do-blocks (block component)
 224          (sb-c::do-nodes (node nil block)
 225            (when (and (sb-c::basic-combination-p node)
 226                       (eq (sb-c::basic-combination-info node) :full)
 227                       (equal (sb-c::combination-fun-debug-name node)
 228                              function-name))
 229              (incf n))))))
 230     n))
 231
 232 (defun disassembly-lines (fun)
 233   ;; FIXME: I don't remember what this override of the hook is for.
 234   (sb-int:encapsulate 'sb-disassem::add-debugging-hooks 'test
 235                       (lambda (f &rest args) (declare (ignore f args))))
 236   (prog1
 237       (mapcar (lambda (x) (string-left-trim " ;" x))
 238               (cddr
 239                (test-util:split-string
 240                 (with-output-to-string (s)
 241                   (let ((sb-disassem:*disassem-location-column-width* 0)
 242                         (*print-pretty* nil))
 243                     (disassemble fun :stream s)))
 244                 #\newline)))
 245     (sb-int:unencapsulate 'sb-disassem::add-debugging-hooks 'test)))