tests/assembler.pure.lisp

   1 ;;;; tests for assembler/disassembler
   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 (in-package sb-vm)
  15
  16 (load "test-util.lisp")
  17 (use-package :test-util)
  18
  19 ;; this is architecture-agnostic
  20 (defun test-assemble (inst expect)
  21   (let ((segment (sb-assem:make-segment :type :regular)))
  22     (sb-assem:assemble (segment)
  23       (apply (sb-assem::op-encoder-name (car inst)) (cdr inst)))
  24     (let* ((buf (sb-assem::segment-buffer segment))
  25            (string
  26             (with-output-to-string (stream)
  27               (with-pinned-objects (buf)
  28                 (let ((sb-disassem:*disassem-location-column-width* 0))
  29                   (sb-disassem:disassemble-memory
  30                    (sap-int (vector-sap buf))
  31                    (sb-assem::segment-current-posn segment)
  32                    :stream stream)))))
  33            (line (string-left-trim'(#\; #\ )
  34                                   (subseq string (1+ (position #\newline string))
  35                                           (1- (length string)))))) ; chop final newline
  36       (assert (string= line expect)))))
  37
  38 (with-test (:name :assemble-movti-instruction :skipped-on (not :x86-64))
  39   (flet ((test-movnti (dst src expect)
  40            (test-assemble `(movnti ,dst ,src) expect)))
  41     (test-movnti (make-ea :dword :base rdi-tn :disp 57) eax-tn
  42                  "0FC34739         MOVNTI [RDI+57], EAX")
  43     (test-movnti (make-ea :qword :base rax-tn) r12-tn
  44                  "4C0FC320         MOVNTI [RAX], R12")))
  45
  46 (with-test (:name :assemble-crc32 :skipped-on (not :x86-64))
  47   ;; Destination size = :DWORD
  48   (test-assemble `(crc32 ,eax-tn ,(make-ea :byte  :base rbp-tn))
  49                  "F20F38F04500     CRC32 EAX, BYTE PTR [RBP]")
  50   (test-assemble `(crc32 ,eax-tn ,(make-ea :word  :base rbp-tn))
  51                  "66F20F38F14500   CRC32 EAX, WORD PTR [RBP]")
  52   (test-assemble `(crc32 ,eax-tn ,(make-ea :dword :base rbp-tn))
  53                  "F20F38F14500     CRC32 EAX, DWORD PTR [RBP]")
  54   ;; these check that the presence of REX does not per se change the width.
  55   (test-assemble `(crc32 ,r9d-tn ,(make-ea :byte  :base r14-tn :index r15-tn))
  56                  "F2470F38F00C3E   CRC32 R9D, BYTE PTR [R14+R15]")
  57   (test-assemble `(crc32 ,r9d-tn ,(make-ea :word  :base r14-tn :index r15-tn))
  58                  "66F2470F38F10C3E CRC32 R9D, WORD PTR [R14+R15]")
  59   (test-assemble `(crc32 ,r9d-tn ,(make-ea :dword :base r14-tn :index r15-tn))
  60                  "F2470F38F10C3E   CRC32 R9D, DWORD PTR [R14+R15]")
  61   ;; Destination size = :QWORD
  62   (test-assemble `(crc32 ,rax-tn ,(make-ea :byte  :base rbp-tn))
  63                  "F2480F38F04500   CRC32 RAX, BYTE PTR [RBP]")
  64   (test-assemble `(crc32 ,rax-tn ,(make-ea :qword :base rbp-tn))
  65                  "F2480F38F14500   CRC32 RAX, QWORD PTR [RBP]")
  66   ;; now with high regs
  67   (test-assemble `(crc32 ,r9-tn ,(make-ea :byte  :base r14-tn :index r15-tn))
  68                  "F24F0F38F00C3E   CRC32 R9, BYTE PTR [R14+R15]")
  69   (test-assemble `(crc32 ,r9-tn ,(make-ea :qword :base r14-tn :index r15-tn))
  70                  "F24F0F38F10C3E   CRC32 R9, QWORD PTR [R14+R15]"))
  71
  72 (with-test (:name :disassemble-arith-insts :skipped-on (not (or :x86 :x86-64)))
  73   (flet ((try (inst expect)
  74            (let ((p (search "$fp" expect)))
  75              (when p
  76                (setq expect
  77                      (concatenate 'string (subseq expect 0 p)
  78                                   #+x86 "EBP" #+x86-64 "RBP"
  79                                   (subseq expect (+ p 3))))))
  80            (test-assemble inst expect))
  81          (memref (size) (make-ea size :base #+x86 ebp-tn #+x86-64 rbp-tn)))
  82     (try `(bt ,(memref :word)  ,ax-tn)  "660FA34500       BT WORD PTR [$fp], AX")
  83     (try `(bt ,(memref :dword) ,eax-tn) "0FA34500         BT DWORD PTR [$fp], EAX")
  84     #+x86-64
  85     (try `(bt ,(memref :qword) ,eax-tn) "480FA34500       BT QWORD PTR [$fp], RAX")
  86     (try `(bt ,(memref :word)  3) "660FBA650003     BT WORD PTR [$fp], 3")
  87     (try `(bt ,(memref :dword) 3) "0FBA650003       BT DWORD PTR [$fp], 3")
  88     #+x86-64
  89     (try `(bt ,(memref :qword) 3) "480FBA650003     BT QWORD PTR [$fp], 3")
  90     ;;
  91     (try `(shld ,eax-tn ,ebx-tn :cl) "0FA5D8           SHLD EAX, EBX, CL")
  92     (try `(shld ,(memref :word)  ,bx-tn 6)  "660FA45D0006     SHLD [$fp], BX, 6")
  93     (try `(shld ,(memref :dword) ,ebx-tn 6) "0FA45D0006       SHLD [$fp], EBX, 6")
  94     #+x86-64
  95     (try `(shld ,(memref :qword) ,rbx-tn 6) "480FA45D0006     SHLD [$fp], RBX, 6")
  96     ;;
  97     (try `(add ,al-tn  #x7f)       "047F             ADD AL, 127")
  98     (try `(add ,ax-tn  #x7fff)     "6605FF7F         ADD AX, 32767")
  99     (try `(add ,eax-tn #x7fffffff) "05FFFFFF7F       ADD EAX, 2147483647")
 100     #+x86-64
 101     (try `(add ,rax-tn #x7fffffff) "4805FFFFFF7F     ADD RAX, 2147483647")
 102     ;;
 103     (try `(add ,bl-tn  #x7f)       "80C37F           ADD BL, 127")
 104     (try `(add ,bx-tn  #x7fff)     "6681C3FF7F       ADD BX, 32767")
 105     (try `(add ,ebx-tn #x7fffffff) "81C3FFFFFF7F     ADD EBX, 2147483647")
 106     #+x86-64
 107     (try `(add ,rbx-tn #x7fffffff) "4881C3FFFFFF7F   ADD RBX, 2147483647")
 108     ;;
 109     (try `(add ,ax-tn  #x7f)       "6683C07F         ADD AX, 127")
 110     (try `(add ,eax-tn #x7f)       "83C07F           ADD EAX, 127")
 111     #+x86-64
 112     (try `(add ,rax-tn #x7f)       "4883C07F         ADD RAX, 127")
 113     ;;
 114     (try `(add ,(memref :byte) ,cl-tn)   "004D00           ADD [$fp], CL")
 115     (try `(add ,(memref :word) ,cx-tn)   "66014D00         ADD [$fp], CX")
 116     (try `(add ,(memref :dword) ,ecx-tn) "014D00           ADD [$fp], ECX")
 117     #+x86-64
 118     (try `(add ,(memref :qword) ,rcx-tn) "48014D00         ADD [$fp], RCX")
 119     (try `(add ,cl-tn ,(memref :byte))   "024D00           ADD CL, [$fp]")
 120     (try `(add ,cx-tn ,(memref :word))   "66034D00         ADD CX, [$fp]")
 121     (try `(add ,ecx-tn ,(memref :dword)) "034D00           ADD ECX, [$fp]")
 122     #+x86-64
 123     (try `(add ,rcx-tn ,(memref :qword)) "48034D00         ADD RCX, [$fp]")
 124     ))
 125
 126 (with-test (:name :disassemble-fs-prefix :skipped-on (not (or :x86-64)))
 127   (let ((bytes (coerce '(#x64 #xF0 #x44 #x08 #x04 #x25 #x00 #x04 #x10 #x20)
 128                        '(array (unsigned-byte 8) 1)))
 129         (s (make-string-output-stream)))
 130     (sb-sys:with-pinned-objects (bytes)
 131       (sb-disassem::disassemble-memory (sb-sys:sap-int (sb-sys:vector-sap bytes))
 132                                        (length bytes)
 133                                        :stream s))
 134     (assert (search "LOCK OR FS:[#x20100400], R8B"
 135                     (get-output-stream-string s)))))
 136
 137 (with-test (:name :disassemble-static-fdefn :skipped-on (not :x86-64))
 138   (assert (< (get-lisp-obj-address (sb-kernel::find-fdefn 'sb-impl::sub-gc))
 139              sb-vm:static-space-end))
 140   ;; Cause SUB-GC to become un-statically-linked
 141   (progn (trace sb-impl::sub-gc) (untrace))
 142   (let ((lines
 143          (split-string (with-output-to-string (s)
 144                          (disassemble 'sb-impl::gc :stream s))
 145                        #\Newline))
 146         (found))
 147     ;; Check that find-called-object looked in static space for FDEFNs
 148     (dolist (line lines)
 149       (when (and (search "CALL" line)
 150                  (search " SUB-GC" line))
 151         (setq found t)))
 152     (assert found)))