tests/disassem.impure.lisp

   1
   2 ;;; Assert that save-lisp-and-die didn't accidentally recreate the inst space.
   3 ;;; Fails in parallel-exec which uses PURE-RUNNER which performs ENCAPSULATE
   4 ;;; which calls UNDO-STATIC-LINKAGE which invokes the disassembler
   5 ;;; which constructs the inst-space.
   6 (with-test (:name :inst-space-jit-constructed
   7                   :fails-on :parallel-test-runner)
   8   (assert (null sb-disassem::*disassem-inst-space*)))
   9
  10 (with-test (:name :disassemble-macro)
  11   (with-output-to-string (s)
  12     (disassemble 'and :stream s)))
  13
  14 (with-test (:name :disassemble-special-form-fails)
  15   (assert-error (disassemble 'progn)))
  16
  17 (with-test (:name :disassemble-sap)
  18   (with-output-to-string (s)
  19     (sb-c:dis (sb-sys:int-sap (+ (- (sb-kernel:get-lisp-obj-address #'car)
  20                                     sb-vm:fun-pointer-lowtag)
  21                                  (* 2 sb-vm:n-word-bytes)))
  22               12
  23               s)))
  24
  25 ;;; CLISP:
  26 ;;;    [1]> (disassemble (defmethod hello ((self cons)) "here i am"))
  27 ;;;    Disassembly of function :LAMBDA
  28 ;;;    (CONST 0) = "here i am"
  29 ;;;    2 required arguments
  30 ;;;    0 optional arguments
  31 ;;;    No rest parameter
  32 ;;;    No keyword parameters
  33 ;;;    2 byte-code instructions:
  34 ;;;    0     (CONST 0)                           ; "here i am"
  35 ;;;    1     (SKIP&RET 3)
  36
  37 ;;; ABCL:
  38 ;;;    CL-USER(1): (disassemble (defmethod hello ((self cons)) "here i am"))
  39 ;;;    /* Java disassembler */
  40 ;;;    ...
  41
  42 ;;; I'm not sure how to implement CLISP-compatibility and ABCL-compatibility
  43 ;;; via the standard interface now, so test the nonstandard interface.
  44 (with-test (:name :disassemble-method
  45             :skipped-on :interpreter)
  46   (with-output-to-string (s)
  47     (sb-c:dis (defmethod hello ((self cons)) "here i am") s)))
  48
  49 (with-test (:name :lp-bug-1861418)
  50   (disassemble '(lambda ()
  51                  (let* ((*s* 692985202))
  52                    (declare (special *s*))
  53                    0))
  54                :stream (make-string-output-stream)))
  55
  56 ;;; This can be used to verify that all of the instruction printers respond
  57 ;;; correctly (or at least, produce no characters on *standard-output*)
  58 ;;; when given NIL as a stream.
  59 ;;; If there is any junk between "Start" and "End" other than the animation
  60 ;;; then something is wrong.
  61 ;;; Unfortunately I think is too slow to make part of the test suite,
  62 ;;; which speaks to the terrible performance of our disassembler.
  63 (in-package "SB-DISASSEM")
  64 (defun list-all-code ()
  65   (sb-vm::list-allocated-objects :all :type sb-vm:code-header-widetag))
  66
  67 (defun disassemble-everything (objects
  68                                &optional (show-progress t)
  69                                &aux (dstate (make-dstate)) (i 0))
  70   (declare (inline %make-segment))
  71   (when show-progress
  72     (format t "~&Start ...  ")
  73     (force-output))
  74   (dolist (code objects)
  75     (when show-progress
  76       (write-char #\backspace)
  77       (write-char (aref "\\|/-" (mod (incf i) 4)))
  78       (force-output))
  79     (dotimes (j (sb-kernel:code-n-entries code))
  80       (let* ((f (sb-kernel:%code-entry-point code j))
  81              (sap (sb-vm:simple-fun-entry-sap f))
  82              (start (sap-int sap))
  83              (len (sb-kernel:%simple-fun-text-len f j)))
  84         ;; we won't - but should - dxify (lambda () start) when so declared
  85         (dx-flet ((sap-maker () sap))
  86           (dx-let ((seg (%make-segment :sap-maker #'sap-maker
  87                                        :virtual-location start
  88                                        :length len)))
  89             (map-segment-instructions
  90              (lambda (chunk inst)
  91                (declare (type dchunk chunk) (type instruction inst))
  92                (awhen (inst-printer inst)
  93                  (funcall it chunk inst nil dstate)
  94                  (setf (dstate-n-operands dstate) 0)))
  95              seg dstate nil))))))
  96   (when show-progress
  97     (format t " done~%")))
  98 (compile 'disassemble-everything)
  99
 100 (defun install-counting-wrapper (discount)
 101   (declare (ignorable discount))
 102   #+x86-64
 103   (sb-int:encapsulate
 104    'sb-x86-64-asm::print-mem-ref 'test
 105    (lambda (realfun &rest args)
 106      ;; Each mem ref disassembled is one cons cell
 107      (incf (car discount) (* sb-vm:cons-size sb-vm:n-word-bytes))
 108      (apply realfun args))))
 109 (compile 'install-counting-wrapper)
 110
 111 ;;; Disassembling everything takes around .8 seconds and conses ~14MB for me.
 112 ;;; To ensure that things don't get drastically worse, assert that we're within
 113 ;;; some fuzz factor of the expected consing. One small mistake in target-disassem
 114 ;;; could leave the disassembler totally working, but consing 10x too much.
 115 (test-util:with-test (:name :disassemble-everything
 116                       ;; Only the x86-64 disassembler is able to disassemble
 117                       ;; with output into the dstate rather than a stream.
 118                       ;; The others choke with "NIL is not of type STREAM"
 119                       :skipped-on (:not :x86-64)
 120                       :broken-on :gc-stress)
 121   (let ((code (list-all-code)) ;; Avoid counting bytes consed in the list
 122         (discount (list 0)))
 123     (install-counting-wrapper discount)
 124     ;; Build the inst space outside the test to avoid influencing bytes consed
 125     (sb-disassem:get-inst-space)
 126     (multiple-value-bind (before after)
 127         (sb-sys:without-gcing
 128             (values (get-bytes-consed)
 129                     (progn
 130                       (disassemble-everything code nil)
 131                       (get-bytes-consed))))
 132       (let* ((after (- after (car discount)))
 133              (delta (- after before)))
 134         (format t "~&Consed ~D bytes discounting ~D bytes~%" delta (car discount))
 135         ;; Should be less than this amount of overhead
 136         (assert (< delta 500000))))))