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-movabs-instruction :skipped-on (not :x86-64))
  73   (let* ((bytes (coerce '(#x48 #xA1 8 7 6 5 4 3 2 1
  74                           #xA1 8 7 6 5 4 3 2 1
  75                           #x66 #xA1 8 7 6 5 4 3 2 1
  76                           #xA0 8 7 6 5 4 3 2 1)
  77                         '(array (unsigned-byte 8) 1)))
  78          (lines
  79           (split-string
  80            (with-output-to-string (s)
  81              (sb-sys:with-pinned-objects (bytes)
  82                (sb-disassem:disassemble-memory
  83                 (sb-sys:sap-int (sb-sys:vector-sap bytes))
  84                 (length bytes)
  85                 :stream s)))
  86            #\newline)))
  87     (pop lines)
  88     (dolist (dest-reg '("RAX" "EAX" "AX" "AL"))
  89       (assert (search (format nil "MOVABS ~A, [#x102030405060708]" dest-reg)
  90                       (pop lines))))))
  91
  92 (with-test (:name :disassemble-arith-insts :skipped-on (not (or :x86 :x86-64)))
  93   (flet ((try (inst expect)
  94            (let ((p (search "$fp" expect)))
  95              (when p
  96                (setq expect
  97                      (concatenate 'string (subseq expect 0 p)
  98                                   #+x86 "EBP" #+x86-64 "RBP"
  99                                   (subseq expect (+ p 3))))))
 100            (test-assemble inst expect))
 101          (memref (size) (make-ea size :base #+x86 ebp-tn #+x86-64 rbp-tn)))
 102     (try `(bt ,(memref :word)  ,ax-tn)  "660FA34500       BT WORD PTR [$fp], AX")
 103     (try `(bt ,(memref :dword) ,eax-tn) "0FA34500         BT DWORD PTR [$fp], EAX")
 104     #+x86-64
 105     (try `(bt ,(memref :qword) ,eax-tn) "480FA34500       BT QWORD PTR [$fp], RAX")
 106     (try `(bt ,(memref :word)  3) "660FBA650003     BT WORD PTR [$fp], 3")
 107     (try `(bt ,(memref :dword) 3) "0FBA650003       BT DWORD PTR [$fp], 3")
 108     #+x86-64
 109     (try `(bt ,(memref :qword) 3) "480FBA650003     BT QWORD PTR [$fp], 3")
 110     ;;
 111     (try `(shld ,eax-tn ,ebx-tn :cl) "0FA5D8           SHLD EAX, EBX, CL")
 112     (try `(shld ,(memref :word)  ,bx-tn 6)  "660FA45D0006     SHLD [$fp], BX, 6")
 113     (try `(shld ,(memref :dword) ,ebx-tn 6) "0FA45D0006       SHLD [$fp], EBX, 6")
 114     #+x86-64
 115     (try `(shld ,(memref :qword) ,rbx-tn 6) "480FA45D0006     SHLD [$fp], RBX, 6")
 116     ;;
 117     (try `(add ,al-tn  #x7f)       "047F             ADD AL, 127")
 118     (try `(add ,ax-tn  #x7fff)     "6605FF7F         ADD AX, 32767")
 119     (try `(add ,eax-tn #x7fffffff) "05FFFFFF7F       ADD EAX, 2147483647")
 120     #+x86-64
 121     (try `(add ,rax-tn #x7fffffff) "4805FFFFFF7F     ADD RAX, 2147483647")
 122     ;;
 123     (try `(add ,bl-tn  #x7f)       "80C37F           ADD BL, 127")
 124     (try `(add ,bx-tn  #x7fff)     "6681C3FF7F       ADD BX, 32767")
 125     (try `(add ,ebx-tn #x7fffffff) "81C3FFFFFF7F     ADD EBX, 2147483647")
 126     #+x86-64
 127     (try `(add ,rbx-tn #x7fffffff) "4881C3FFFFFF7F   ADD RBX, 2147483647")
 128     ;;
 129     (try `(add ,ax-tn  #x7f)       "6683C07F         ADD AX, 127")
 130     (try `(add ,eax-tn #x7f)       "83C07F           ADD EAX, 127")
 131     #+x86-64
 132     (try `(add ,rax-tn #x7f)       "4883C07F         ADD RAX, 127")
 133     ;;
 134     (try `(add ,(memref :byte) ,cl-tn)   "004D00           ADD [$fp], CL")
 135     (try `(add ,(memref :word) ,cx-tn)   "66014D00         ADD [$fp], CX")
 136     (try `(add ,(memref :dword) ,ecx-tn) "014D00           ADD [$fp], ECX")
 137     #+x86-64
 138     (try `(add ,(memref :qword) ,rcx-tn) "48014D00         ADD [$fp], RCX")
 139     (try `(add ,cl-tn ,(memref :byte))   "024D00           ADD CL, [$fp]")
 140     (try `(add ,cx-tn ,(memref :word))   "66034D00         ADD CX, [$fp]")
 141     (try `(add ,ecx-tn ,(memref :dword)) "034D00           ADD ECX, [$fp]")
 142     #+x86-64
 143     (try `(add ,rcx-tn ,(memref :qword)) "48034D00         ADD RCX, [$fp]")
 144     ))
 145
 146 (with-test (:name :disassemble-fs-prefix :skipped-on (not (or :x86-64)))
 147   (let ((bytes (coerce '(#x64 #xF0 #x44 #x08 #x04 #x25 #x00 #x04 #x10 #x20)
 148                        '(array (unsigned-byte 8) 1)))
 149         (s (make-string-output-stream)))
 150     (sb-sys:with-pinned-objects (bytes)
 151       (sb-disassem::disassemble-memory (sb-sys:sap-int (sb-sys:vector-sap bytes))
 152                                        (length bytes)
 153                                        :stream s))
 154     (assert (search "LOCK OR FS:[#x20100400], R8B"
 155                     (get-output-stream-string s)))))
 156
 157 (with-test (:name :disassemble-static-fdefn :skipped-on (not :x86-64))
 158   (assert (< (get-lisp-obj-address (sb-kernel::find-fdefn 'sb-impl::sub-gc))
 159              sb-vm:static-space-end))
 160   ;; Cause SUB-GC to become un-statically-linked
 161   (progn (trace sb-impl::sub-gc) (untrace))
 162   (let ((lines
 163          (split-string (with-output-to-string (s)
 164                          (disassemble 'sb-impl::gc :stream s))
 165                        #\Newline))
 166         (found))
 167     ;; Check that find-called-object looked in static space for FDEFNs
 168     (dolist (line lines)
 169       (when (and (search "CALL" line)
 170                  (search " SUB-GC" line))
 171         (setq found t)))
 172     (assert found)))