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 (when (member :linkage-space sb-impl:+internal-features+) ; for below
 114   (pushnew :linkage-space *features*))
 115
 116 (defun find-named-callees (fun &key (name nil namep))
 117   (let ((code (fun-code-header (%fun-fun fun))))
 118     #+linkage-space
 119     (loop for index in (sb-c:unpack-code-fixup-locs (sb-vm::%code-fixups code))
 120           for this = (sb-vm::linkage-addr->name index :index)
 121           when (or (not namep) (equal this name))
 122           collect this)
 123     #-linkage-space
 124     (sb-int:binding* (((start count) (sb-kernel:code-header-fdefn-range code)))
 125       (loop for i from start repeat count
 126             for c = (code-header-ref code i)
 127             when (or (not namep) (equal name (sb-kernel:fdefn-name c)))
 128             collect (sb-kernel:fdefn-name c)))))
 129
 130 (defun find-anonymous-callees (fun &key (type 'function))
 131   (let ((code (fun-code-header (%fun-fun fun))))
 132     (loop for i from sb-vm:code-constants-offset below (code-header-words code)
 133           for fun = (code-header-ref code i)
 134           when (typep fun type)
 135           collect fun)))
 136
 137 ;;; Return a subset of the code constants for FUN's code but excluding
 138 ;;; constants that are present on behalf of %SIMPLE-FUN-foo accessors.
 139 (defun find-code-constants (fun &key (type t))
 140   (let ((code (fun-code-header (%fun-fun fun))))
 141     (loop for i from sb-vm:code-constants-offset
 142           below (code-header-words code)
 143           for c = (code-header-ref code i)
 144           for value = (if (= (widetag-of c) sb-vm:value-cell-widetag)
 145                           (value-cell-ref c)
 146                           c)
 147           when (and (not (eql value 0)) ;; alignment zeros
 148                     (typep value type))
 149           collect value)))
 150
 151 (defun collect-consing-stats (thunk times)
 152   (declare (type function thunk))
 153   (declare (type fixnum times))
 154   #+(and sb-thread gencgc) (sb-vm::close-thread-alloc-region)
 155   (setf sb-int:*n-bytes-freed-or-purified* 0)
 156   (let ((before (sb-ext:get-bytes-consed)))
 157     (dotimes (i times)
 158       (funcall thunk))
 159     (values before (sb-ext:get-bytes-consed))))
 160
 161 (defun check-consing (yes/no form thunk times)
 162   (multiple-value-bind (before after)
 163       (collect-consing-stats thunk times)
 164     (let* ((consed-bytes (- after before))
 165            (bytes-per-iteration (float (/ consed-bytes times))))
 166       (assert (progn
 167                 (funcall (if yes/no #'not #'identity)
 168                          ;; If allocation really happened, it can't have been less than one cons cell
 169                          ;; per iteration (unless the test is nondeterministic - but in that case
 170                          ;; we can't really use this strategy anyway). So consider it to have consed
 171                          ;; nothing if the fraction is too small.
 172                          (< bytes-per-iteration (* 2 sb-vm:n-word-bytes)))
 173                 #+gc-stress t)
 174               ()
 175               "~@<Expected the form ~
 176                       ~4I~@:_~A ~0I~@:_~
 177                   ~:[NOT to cons~;to cons~], yet running it for ~
 178                   ~D times resulted in the allocation of ~
 179                   ~D bytes~:[ (~,3F per run)~;~].~@:>"
 180               form yes/no times consed-bytes
 181               (zerop consed-bytes) bytes-per-iteration))
 182     (values before after)))
 183
 184 (defparameter +times+ 10000)
 185
 186 (defmacro assert-no-consing (form &optional (times '+times+))
 187   `(check-consing nil ',form (lambda () ,form) ,times))
 188
 189 (defmacro assert-consing (form &optional (times '+times+))
 190   `(check-consing t ',form (lambda () ,form) ,times))
 191
 192 (defun file-compile (toplevel-forms &key load
 193                                          before-load
 194                                          block-compile)
 195   (let* ((lisp (test-util:scratch-file-name "lisp"))
 196          (fasl (compile-file-pathname lisp))
 197          (error-stream (make-string-output-stream)))
 198     (unwind-protect
 199          (progn
 200            (with-open-file (f lisp :direction :output)
 201              (if (stringp toplevel-forms)
 202                  (write-line toplevel-forms f)
 203                  (dolist (form toplevel-forms)
 204                    (prin1 form f))))
 205            ;; Preserve all referenced callees. This has no effect on semantics
 206            (sb-int:encapsulate 'sb-int:permanent-fname-p 'test-shim #'sb-int:constantly-nil)
 207            (multiple-value-bind (fasl warn fail)
 208                (let ((*error-output* error-stream))
 209                  (compile-file lisp :print nil :verbose nil
 210                                     :block-compile block-compile))
 211              (when load
 212                (when before-load
 213                  (funcall before-load))
 214                (let ((*error-output* error-stream))
 215                  (load fasl :print nil :verbose nil)))
 216              (values warn fail error-stream)))
 217       (sb-int:unencapsulate 'sb-int:permanent-fname-p 'test-shim)
 218       (ignore-errors (delete-file lisp))
 219       (ignore-errors (delete-file fasl)))))
 220
 221 ;;; TODO: this would be better done as LIST-FULL-CALLS so that you could
 222 ;;; make an assertion that the list EQUALs something in particular.
 223 ;;; Negative assertions (essentially "count = 0") are silently susceptible
 224 ;;; to spelling mistakes or a change in how we name nodes.
 225 (defun count-full-calls (function-name lambda-expression)
 226   (declare (ignorable function-name lambda-expression))
 227   #-sb-devel
 228   (throw 'test-util::skip-test t)
 229   #+sb-devel
 230   (let ((n 0))
 231     (inspect-ir
 232      lambda-expression
 233      (lambda (component)
 234        (sb-c::do-blocks (block component)
 235          (sb-c::do-nodes (node nil block)
 236            (when (and (sb-c::basic-combination-p node)
 237                       (eq (sb-c::basic-combination-info node) :full)
 238                       (equal (sb-c::combination-fun-debug-name node)
 239                              function-name))
 240              (incf n))))))
 241     n))
 242
 243 (defun disassembly-lines (fun)
 244   ;; FIXME: I don't remember what this override of the hook is for.
 245   (sb-int:encapsulate 'sb-disassem::add-debugging-hooks 'test
 246                       (lambda (f &rest args) (declare (ignore f args))))
 247   (prog1
 248       (mapcar (lambda (x) (string-left-trim " ;" x))
 249               (cddr
 250                (test-util:split-string
 251                 (with-output-to-string (s)
 252                   (let ((sb-disassem:*disassem-location-column-width* 0)
 253                         (*print-pretty* nil))
 254                     (disassemble fun :stream s)))
 255                 #\newline)))
 256     (sb-int:unencapsulate 'sb-disassem::add-debugging-hooks 'test)))