common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity
sbcl.sbcl/tests/assembler.pure.lisp
Stas Boukarev 92198f3921 x86-64: annotate NIL and T in disassemble.
2025-04-12 06:47:45 +03:00

340 lines
16 KiB
Common Lisp
Raw Blame History

;;;; tests for assembler/disassembler
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(cl:in-package "SB-VM")
(test-util:enable-test-parallelism)
;; this is architecture-agnostic
(defun test-assemble (inst expect)
(let ((segment (sb-assem:make-segment)))
(sb-assem:assemble (segment 'nil)
(apply #'sb-assem:inst* (car inst) (cdr inst)))
(let* ((buf (sb-assem:segment-buffer segment))
(string
(with-output-to-string (stream)
(with-pinned-objects (buf)
(let ((sb-disassem:*disassem-location-column-width* 0))
(sb-disassem:disassemble-memory
(sap-int (vector-sap buf))
(sb-assem::segment-current-posn segment)
:stream stream)))))
(line (string-left-trim'(#\; #\ )
(subseq string (1+ (position #\newline string))
(1- (length string)))))) ; chop final newline
(assert (string= line expect)))))
(defun check-does-not-assemble (instruction)
(handler-case (test-assemble instruction "")
(error nil)
(:no-error (x) x (error "Should not assemble"))))
;;; Create some special variables that are needed for tests
;;; since they no longer exist as part of the vm definition.
#+x86-64
(macrolet ((define (name qword-tn size)
`(defvar ,name
(sb-x86-64-asm::sized-thing (sb-x86-64-asm::tn-reg ,qword-tn)
,size))))
(define al rax-tn :byte)
(define bl rbx-tn :byte)
(define cl rcx-tn :byte)
(define dl rdx-tn :byte)
(define dil rdi-tn :byte)
(define r8b r8-tn :byte)
(define ax rax-tn :word)
(define bx rbx-tn :word)
(define cx rcx-tn :word)
(define r8w r8-tn :word)
(define eax rax-tn :dword)
(define ebx rbx-tn :dword)
(define ecx rcx-tn :dword)
(define edx rdx-tn :dword)
(define edi rdi-tn :dword)
(define r8d r8-tn :dword)
(define r9d r9-tn :dword))
#+x86
(progn (defglobal al al-tn) (defglobal ax ax-tn) (defglobal eax eax-tn)
(defglobal bl bl-tn) (defglobal bx bx-tn) (defglobal ebx ebx-tn)
(defglobal cl cl-tn) (defglobal cx cx-tn) (defglobal ecx ecx-tn)
(defglobal dl dl-tn)
(defglobal edi edi-tn))
(test-util:with-test (:name :assemble-movnti-instruction :skipped-on (not :x86-64))
(flet ((test-movnti (dst src expect)
(test-assemble `(movnti ,dst ,src) expect)))
(test-movnti (ea 57 rdi-tn) eax "0FC34739 MOVNTI [RDI+57], EAX")
(test-movnti (ea rax-tn) r11-tn "4C0FC318 MOVNTI [RAX], R11")))
(test-util:with-test (:name :assemble-crc32 :skipped-on (not :x86-64))
;; Destination size = :DWORD
(test-assemble `(crc32 :byte ,eax ,(ea rbp-tn))
"F20F38F04500 CRC32 EAX, BYTE PTR [RBP]")
(test-assemble `(crc32 :byte ,eax (,rcx-tn . :high-byte))
"F20F38F0C5 CRC32 EAX, CH")
(test-assemble `(crc32 :byte ,eax ,dil)
"F2400F38F0C7 CRC32 EAX, DIL")
(test-assemble `(crc32 :word ,eax ,(ea rbp-tn))
"66F20F38F14500 CRC32 EAX, WORD PTR [RBP]")
(test-assemble `(crc32 :dword ,eax ,(ea rbp-tn))
"F20F38F14500 CRC32 EAX, DWORD PTR [RBP]")
;; these check that the presence of REX does not per se change the width.
(test-assemble `(crc32 :byte ,r9d ,(ea r14-tn r15-tn))
"F2470F38F00C3E CRC32 R9D, BYTE PTR [R14+R15]")
(test-assemble `(crc32 :word ,r9d ,(ea r14-tn r15-tn))
"66F2470F38F10C3E CRC32 R9D, WORD PTR [R14+R15]")
(test-assemble `(crc32 :dword ,r9d ,(ea r14-tn r15-tn))
"F2470F38F10C3E CRC32 R9D, DWORD PTR [R14+R15]")
;; Destination size = :QWORD
(test-assemble `(crc32 :byte ,rax-tn ,(ea rbp-tn))
"F2480F38F04500 CRC32 RAX, BYTE PTR [RBP]")
(test-assemble `(crc32 :qword ,rax-tn ,(ea rbp-tn))
"F2480F38F14500 CRC32 RAX, QWORD PTR [RBP]")
;; now with high regs
(test-assemble `(crc32 :byte ,r9-tn ,(ea r14-tn r15-tn))
"F24F0F38F00C3E CRC32 R9, BYTE PTR [R14+R15]")
(test-assemble `(crc32 :qword ,r9-tn ,(ea r14-tn r15-tn))
"F24F0F38F10C3E CRC32 R9, QWORD PTR [R14+R15]"))
(test-util:with-test (:name :assemble-unsigned-qword-imm-to-mem :skipped-on (not :x86-64))
;; unsigned bits cast as signed bits
(let ((const #xffffffff801234BB))
(test-assemble `(mov :qword ,(ea rcx-tn) ,const)
"48C701BB341280 MOV QWORD PTR [RCX], -2146290501")
;; Do not truncate to just the lower bits
(dolist (size '(:byte :word :dword))
(check-does-not-assemble `(mov ,size ,(ea rcx-tn) ,const)))))
(test-util:with-test (:name :unsigned-as-signed-imm8 :skipped-on (not :x86-64))
;; PUSH
(test-assemble `(push #xfffffffffffffffc) "6AFC PUSH -4")
;; ADD/SUB/etc
(test-assemble `(and ,rax-tn #xffffffffffffff8c)
"4883E08C AND RAX, -116")
(test-assemble `(sub ,eax #xfffffffc) "83E8FC SUB EAX, -4")
;; Register AX could use the special 1-byte opcode and non-sign-extended
;; imm16 operand; the encoding length is the same either way.
(test-assemble `(or ,ax #xfff7) "6683C8F7 OR AX, -9"))
(test-util:with-test (:name :assemble-movsx :skipped-on (not :x86-64))
;; source = :BYTE, signed
(check-does-not-assemble `(movsx (:byte :byte) ,r8b ,cl))
(test-assemble `(movsx (:byte :word) ,r8w ,cl) "66440FBEC1 MOVSX R8W, CL")
(test-assemble `(movsx (:byte :dword) ,r8d ,cl) "440FBEC1 MOVSX R8D, CL")
(test-assemble `(movsx (:byte :qword) ,r8-tn ,cl) "4C0FBEC1 MOVSX R8, CL")
;; source = :BYTE, unsigned
(check-does-not-assemble `(movzx (:byte :byte) ,r8b ,cl))
(test-assemble `(movzx (:byte :word) ,r8w ,cl) "66440FB6C1 MOVZX R8W, CL")
(test-assemble `(movzx (:byte :dword) ,r8d ,cl) "440FB6C1 MOVZX R8D, CL")
(test-assemble `(movzx (:byte :qword) ,r8-tn ,cl) "4C0FB6C1 MOVZX R8, CL")
;; source = :WORD, signed
(test-assemble `(movsx (:word :dword) ,r8d ,cx) "440FBFC1 MOVSX R8D, CX")
(test-assemble `(movsx (:word :qword) ,r8-tn ,cx) "4C0FBFC1 MOVSX R8, CX")
;; source = :WORD, unsigned
(test-assemble `(movzx (:word :dword) ,r8d ,cx) "440FB7C1 MOVZX R8D, CX")
(test-assemble `(movzx (:word :qword) ,r8-tn ,cx) "4C0FB7C1 MOVZX R8, CX")
;; source = :DWORD, signed and unsigned
(test-assemble `(movsx (:dword :qword) ,r8-tn ,ecx) "4C63C1 MOVSX R8, ECX"))
(test-util:with-test (:name :disassemble-movabs-instruction :skipped-on (not :x86-64))
(let* ((bytes (coerce '(#x48 #xA1 8 7 6 5 4 3 2 1
#xA1 8 7 6 5 4 3 2 1
#x66 #xA1 8 7 6 5 4 3 2 1
#xA0 8 7 6 5 4 3 2 1)
'(array (unsigned-byte 8) 1)))
(lines
(test-util:split-string
(with-output-to-string (s)
(sb-sys:with-pinned-objects (bytes)
(sb-disassem:disassemble-memory
(sb-sys:sap-int (sb-sys:vector-sap bytes))
(length bytes)
:stream s)))
#\newline)))
(pop lines)
(dolist (dest-reg '("RAX" "EAX" "AX" "AL"))
(assert (search (format nil "MOVABS ~A, [#x102030405060708]" dest-reg)
(pop lines))))))
(test-util:with-test (:name :disassemble-arith-insts :skipped-on (not (or :x86 :x86-64)))
(flet ((try (inst expect)
(let ((p (search "$fp" expect)))
(when p
(setq expect
(concatenate 'string (subseq expect 0 p)
#+x86 "EBP" #+x86-64 "RBP"
(subseq expect (+ p 3))))))
(destructuring-bind (opcode operand1 operand2 . more) inst
(when (or (typep operand1 '(cons (eql memref)))
(typep operand2 '(cons (eql memref))))
#+x86-64
(let ((prefix (second (if (consp operand1) operand1 operand2))))
(flet ((new-ea (operand) (if (consp operand) (ea rbp-tn) operand)))
(setf inst
(list* opcode prefix (new-ea operand1) (new-ea operand2) more))))
#+x86
(flet ((new-ea (operand)
(if (consp operand) (make-ea (second operand) :base ebp-tn) operand)))
(setf inst (list* opcode (new-ea operand1) (new-ea operand2) more)))))
(test-assemble inst expect)))
(try `(bt (memref :word) ,ax) "660FA34500 BT WORD PTR [$fp], AX")
(try `(bt (memref :dword) ,eax) "0FA34500 BT DWORD PTR [$fp], EAX")
#+x86-64
(try `(bt (memref :qword) ,rax-tn) "480FA34500 BT QWORD PTR [$fp], RAX")
(try `(bt (memref :word) 3) "660FBA650003 BT WORD PTR [$fp], 3")
(try `(bt (memref :dword) 3) "0FBA650003 BT DWORD PTR [$fp], 3")
#+x86-64
(try `(bt (memref :qword) 3) "480FBA650003 BT QWORD PTR [$fp], 3")
;;
(try `(shld ,eax ,ebx :cl) "0FA5D8 SHLD EAX, EBX, CL")
(try `(shld (memref :word) ,bx 6) "660FA45D0006 SHLD [$fp], BX, 6")
(try `(shld (memref :dword) ,ebx 6) "0FA45D0006 SHLD [$fp], EBX, 6")
#+x86-64
(try `(shld (memref :qword) ,rbx-tn 6) "480FA45D0006 SHLD [$fp], RBX, 6")
;;
(try `(add ,al #x7f) "047F ADD AL, 127")
(try `(add ,ax #x7fff) "6605FF7F ADD AX, 32767")
(try `(add ,eax #x7fffffff) "05FFFFFF7F ADD EAX, 2147483647")
#+x86-64
(try `(add ,rax-tn #x7fffffff) "4805FFFFFF7F ADD RAX, 2147483647")
;;
(try `(add ,bl #x7f) "80C37F ADD BL, 127")
(try `(add ,bx #x7fff) "6681C3FF7F ADD BX, 32767")
(try `(add ,ebx #x7fffffff) "81C3FFFFFF7F ADD EBX, 2147483647")
#+x86-64
(try `(add ,rbx-tn #x7fffffff) "4881C3FFFFFF7F ADD RBX, 2147483647")
;;
(try `(add ,ax #x7f) "6683C07F ADD AX, 127")
(try `(add ,eax #x7f) "83C07F ADD EAX, 127")
#+x86-64
(try `(add ,rax-tn #x7f) "4883C07F ADD RAX, 127")
;;
(try `(add (memref :byte) ,cl) "004D00 ADD [$fp], CL")
(try `(add (memref :word) ,cx) "66014D00 ADD [$fp], CX")
(try `(add (memref :dword) ,ecx) "014D00 ADD [$fp], ECX")
#+x86-64
(try `(add (memref :qword) ,rcx-tn) "48014D00 ADD [$fp], RCX")
(try `(add ,cl (memref :byte)) "024D00 ADD CL, [$fp]")
(try `(add ,cx (memref :word)) "66034D00 ADD CX, [$fp]")
(try `(add ,ecx (memref :dword)) "034D00 ADD ECX, [$fp]")
#+x86-64
(try `(add ,rcx-tn (memref :qword)) "48034D00 ADD RCX, [$fp]")
))
(test-util:with-test (:name :disassemble-imul :skipped-on (not (or :x86 :x86-64)))
(test-assemble `(imul ,dl) "F6EA IMUL DL")
(test-assemble `(imul ,cx) "66F7E9 IMUL CX")
(test-assemble `(imul ,ebx) "F7EB IMUL EBX")
(test-assemble `(imul ,edi 92) "6BFF5C IMUL EDI, EDI, 92"))
(test-util:with-test (:name :disassemble-fs-prefix :skipped-on (not (or :x86-64)))
(let ((bytes (coerce '(#x64 #xF0 #x44 #x08 #x04 #x25 #x00 #x04 #x10 #x20)
'(array (unsigned-byte 8) 1)))
(s (make-string-output-stream)))
(sb-sys:with-pinned-objects (bytes)
(sb-disassem::disassemble-memory (sb-sys:sap-int (sb-sys:vector-sap bytes))
(length bytes)
:stream s))
(assert (search "LOCK OR FS:[#x20100400], R8B"
(get-output-stream-string s)))))
(test-util:with-test (:name :cast-reg-to-size :skipped-on (not :x86-64))
(test-assemble `(mov :byte ,rsi-tn ,rdi-tn)
"408AF7 MOV SIL, DIL")
(test-assemble `(movsx (:byte :word) ,rax-tn ,rdi-tn)
"66400FBEC7 MOVSX AX, DIL")
(test-assemble `(cmpxchg :byte ,(ea rax-tn) ,rdi-tn)
"400FB038 CMPXCHG [RAX], DIL")
(test-assemble `(cmp :byte ,rdi-tn ,rsi-tn)
"4038F7 CMP DIL, SIL")
(test-assemble `(not :byte ,rsi-tn)
"40F6D6 NOT SIL")
(test-assemble `(rol :byte ,rsi-tn 2)
"40C0C602 ROL SIL, 2")
(test-assemble `(test :byte ,rsi-tn 15)
"40F6C60F TEST SIL, 15")
(test-assemble `(movd ,float0-tn ,rax-tn)
"660F6EC0 MOVD XMM0, EAX")
(test-assemble `(movq ,float0-tn ,eax)
"66480F6EC0 MOVQ XMM0, RAX"))
(test-util:with-test (:name :assemble-high-byte-regs :skipped-on (not :x86-64))
(test-assemble `(cmp (,rdx-tn . :high-byte) 1)
"80FE01 CMP DH, 1")
(test-assemble `(mov (,rdx-tn . :high-byte) (,rcx-tn . :high-byte))
"8AF5 MOV DH, CH")
;; can not use legacy high byte reg in a REX-prefixed instruction
(check-does-not-assemble `(movsx (:byte :qword) ,rax-tn (,rbx-tn . :high-byte))))
(defun try (inst)
(let ((segment (sb-assem:make-segment)))
(sb-assem:assemble (segment 'nil)
(apply #'sb-assem:inst* (car inst) (cdr inst)))
(let* ((buf (sb-assem:segment-buffer segment))
(string
(with-output-to-string (stream)
(with-pinned-objects (buf)
(let ((sb-disassem:*disassem-location-column-width* 0))
(sb-disassem:disassemble-memory
(sap-int (vector-sap buf))
(sb-assem::segment-current-posn segment)
:stream stream)))))
(line (string-left-trim'(#\; #\ )
(subseq string (1+ (position #\newline string))
(1- (length string)))))) ; chop final newline
(declare (ignorable line))
;;(print line)
)))
#+x86-64
(test-util:with-test (:name :muldiv)
;; This just assserts that we can assemble. It doesn't check
;; against the expected encoding or disassembly.
(dolist (size '(:byte :word :dword :qword nil))
(dolist (op '(mul div idiv))
(if size
(try `(,op ,size ,rbx-tn))
(try `(,op ,rbx-tn))))))
#+x86-64
(test-util:with-test (:name :imul)
(dolist (reg `(,r9-tn)) ;
;; 1-operand form yielding a double-width result into rAX:rDX
(dolist (size '(:byte :word :dword :qword))
(try `(imul ,size ,reg))
(try `(imul ,size ,(ea reg)))
(try `(imul ,size ,(ea #x1000))))
(try `(imul ,reg)) ; default to :QWORD
;; 2-operand form. There is no :BYTE size
(dolist (size '(:word :dword :qword))
(try `(imul ,size ,reg ,reg))
(try `(imul ,size ,reg ,(ea reg)))
(try `(imul ,size ,reg ,(ea #x1000))))
(try `(imul ,reg ,r10-tn)) ; default to :QWORD
;; 3-operand form with 8-bit signed imm
(try `(imul :word ,rbx-tn ,(ea rdx-tn) -128))
(try `(imul :dword ,rbx-tn ,(ea rdx-tn) -128))
(try `(imul :qword ,rbx-tn ,(ea rdx-tn) -128))
;; 3-operand form with 16-bit signed imm
(try `(imul :word ,rbx-tn ,(ea rdx-tn) -32768))
;; 3-operand form with 32-bit signed imm
(try `(imul :dword ,rbx-tn ,(ea rdx-tn) #xbaba))
(try `(imul :qword ,rbx-tn ,(ea rdx-tn) #xbaba))))
(test-util:with-test (:name :mxcsr-loadstore :skipped-on (not :x86-64))
;; This just assserts that we can assemble
(try `(ldmxcsr ,(ea rax-tn)))
(try `(stmxcsr ,(ea rax-tn))))
Reference in a new issue View git blame Copy permalink