tests/x86-64-codegen.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 #-(and x86-64 immobile-space sb-thread) (sb-ext:exit :code 104) ; can't run these tests
  13
  14 (defun disasm (safety expr &optional (remove-epilogue t))
  15   ;; This lambda has a name because if it doesn't, then the name
  16   ;; is something stupid like (lambda () in ...) which pretty-prints
  17   ;; on a random number of lines.
  18   (let ((fun (compile nil
  19                       `(sb-int:named-lambda test ()
  20                          (declare (optimize (debug 0) (safety ,safety)
  21                                             (sb-c::verify-arg-count 0)))
  22                          ,expr))))
  23     (sb-int:encapsulate 'sb-disassem::add-debugging-hooks 'test
  24                         (lambda (f &rest args) (declare (ignore f args))))
  25     (let ((lines
  26            (split-string
  27             (with-output-to-string (s)
  28               (let ((sb-disassem:*disassem-location-column-width* 0))
  29                 (disassemble fun :stream s)))
  30             #\newline)))
  31       (sb-int:unencapsulate 'sb-disassem::add-debugging-hooks 'test)
  32       (setq lines (cddr lines)) ; remove "Disassembly for"
  33       (when (string= (car (last lines)) "")
  34         (setq lines (nbutlast lines)))
  35       ;; For human-readability, kill the whitespace
  36       (setq lines (mapcar (lambda (x) (string-left-trim " ;" x)) lines))
  37       ;; If the last 4 lines are of the expected form
  38       ;;   MOV RSP, RBP / CLC / POP RBP / RET
  39       ;; then strip them out
  40       (if (and remove-epilogue
  41                (every #'search
  42                       '("MOV RSP, RBP" "CLC" "POP RBP" "RET")
  43                       (subseq lines (- (length lines) 4))))
  44           (butlast lines 4)
  45           lines))))
  46
  47 (with-test (:name :symeval-known-thread-local)
  48   ;; It should take 1 instruction to read a known thread-local var
  49   (assert (= (length (disasm 1 'sb-thread:*current-thread*)) 1))
  50   (assert (= (length (disasm 1 'sb-kernel:*restart-clusters*)) 1))
  51   (assert (= (length (disasm 1 'sb-kernel:*handler-clusters*)) 1)))
  52
  53 ;; Lack of earmuffs on this symbol allocates it in dynamic space
  54 (defvar foo)
  55 (assert (not (sb-kernel:immobile-space-obj-p 'foo)))
  56 ;; This compilation causes a side-effect of assigning FOO a TLS index
  57 ;; DO NOT REMOVE!
  58 (compile nil '(lambda (foo) (eval 'frob)))
  59
  60 (with-test (:name :symeval-known-tls-index)
  61   ;; When symbol SC is IMMEDIATE:
  62   ;;    498B942478210000   MOV RDX, [R12+8568]       ; tls: *PRINT-BASE*
  63   ;;    83FA61             CMP EDX, 97
  64   ;;    480F44142538F94B20 CMOVEQ RDX, [#x204BF938]  ; *PRINT-BASE*
  65   ;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
  66   (assert (= (length (disasm 0 '*print-base*)) 3))
  67
  68   ;; When symbol SC is CONSTANT:
  69   ;;    498B942478290000   MOV RDX, [R12+10616]        ; tls: FOO
  70   ;;    488B05A4FFFFFF     MOV RAX, [RIP-92]           ; 'FOO
  71   ;;    83FA61             CMP EDX, 97
  72   ;;    480F4450F9         CMOVEQ RDX, [RAX-7]
  73   (assert (= (length (disasm 0 'foo)) 4)))
  74
  75 (defvar *blub*) ; immobile space
  76 (defvar blub)   ; dynamic space
  77 (assert (sb-kernel:immobile-space-obj-p '*blub*))
  78 (assert (not (sb-kernel:immobile-space-obj-p 'blub)))
  79
  80 (with-test (:name :symeval-unknown-tls-index)
  81   ;; When symbol SC is immediate:
  82   ;;    8B142514A24C20     MOV EDX, [#x204CA214]    ; tls_index: *BLUB*
  83   ;;    498B1414           MOV RDX, [R12+RDX]
  84   ;;    83FA61             CMP EDX, 97
  85   ;;    480F44142518A24C20 CMOVEQ RDX, [#x204CA218] ; *BLUB*
  86   ;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
  87   (assert (= (length (disasm 0 '*blub*)) 4))
  88
  89   ;; When symbol SC is constant:
  90   ;;    488B05B3FFFFFF     MOV RAX, [RIP-77]          ; 'BLUB"
  91   ;;    8B50F5             MOV EDX, [RAX-11]
  92   ;;    498B1414           MOV RDX, [R12+RDX]
  93   ;;    83FA61             CMP EDX, 97
  94   ;;    480F4450F9         CMOVEQ RDX, [RAX-7]
  95   (assert (= (length (disasm 0 'blub)) 5)))
  96
  97 (with-test (:name :object-not-type-error-encoding)
  98   ;; There should not be a "MOV Rnn, #xSYMBOL" instruction
  99   ;; before the OBJECT-NOT-TYPE-ERROR.
 100   (let* ((lines
 101           (split-string
 102            (with-output-to-string (s)
 103             (let ((sb-disassem:*disassem-location-column-width* 0))
 104               (disassemble '(lambda (x) (the sb-assem:label x))
 105                            :stream s)))
 106            #\newline))
 107          (index
 108           (position "; error trap" lines :test 'search)))
 109     (assert (search "OBJECT-NOT-TYPE-ERROR" (nth (1+ index) lines)))
 110     (assert (search "; 'SB-ASSEM:LABEL" (nth (+ index 3) lines)))))
 111
 112 #+immobile-code
 113 (with-test (:name :reference-assembly-tramp)
 114   (dolist (testcase '(("FUNCALLABLE-INSTANCE-TRAMP"
 115                        sb-kernel:%make-funcallable-instance)
 116                       ("UNDEFINED-TRAMP"
 117                        sb-kernel:make-fdefn)))
 118     (let ((lines
 119            (split-string
 120             (with-output-to-string (stream)
 121               (let ((sb-disassem:*disassem-location-column-width* 0))
 122                 (disassemble (cadr testcase) :stream stream)))
 123             #\newline)))
 124       (assert (loop for line in lines
 125                     thereis (and (search "LEA" line)
 126                                  (search "RIP" line) ; require RIP-relative mode
 127                                  ;; and verify disassembly
 128                                  (search (car testcase) line)))))))