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       ;; Remove safepoint traps
  38       (setq lines (remove-if (lambda (x) (search "; safepoint" x)) lines))
  39       ;; If the last 4 lines are of the expected form
  40       ;;   MOV RSP, RBP / CLC / POP RBP / RET
  41       ;; then strip them out
  42       (if (and remove-epilogue
  43                (every #'search
  44                       '("MOV RSP, RBP" "CLC" "POP RBP" "RET")
  45                       (subseq lines (- (length lines) 4))))
  46           (butlast lines 4)
  47           lines))))
  48
  49 (with-test (:name :symeval-known-thread-local)
  50   ;; It should take 1 instruction to read a known thread-local var
  51   (assert (= (length (disasm 1 'sb-thread:*current-thread*)) 1))
  52   (assert (= (length (disasm 1 'sb-kernel:*restart-clusters*)) 1))
  53   (assert (= (length (disasm 1 'sb-kernel:*handler-clusters*)) 1)))
  54
  55 ;; Lack of earmuffs on this symbol allocates it in dynamic space
  56 (defvar foo)
  57 #-immobile-symbols (assert (not (sb-kernel:immobile-space-obj-p 'foo)))
  58 ;; This compilation causes a side-effect of assigning FOO a TLS index
  59 ;; DO NOT REMOVE!
  60 (compile nil '(lambda (foo) (eval 'frob)))
  61
  62 (with-test (:name :symeval-known-tls-index :skipped-on :immobile-symbols)
  63   ;; When symbol SC is IMMEDIATE:
  64   ;;    498B942478210000   MOV RDX, [R12+8568]       ; tls: *PRINT-BASE*
  65   ;;    83FA61             CMP EDX, 97
  66   ;;    480F44142538F94B20 CMOVEQ RDX, [#x204BF938]  ; *PRINT-BASE*
  67   ;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
  68   (assert (= (length (disasm 0 '*print-base*)) 3))
  69
  70   ;; When symbol SC is CONSTANT:
  71   ;;    498B942478290000   MOV RDX, [R12+10616]        ; tls: FOO
  72   ;;    488B05A4FFFFFF     MOV RAX, [RIP-92]           ; 'FOO
  73   ;;    83FA61             CMP EDX, 97
  74   ;;    480F4450F9         CMOVEQ RDX, [RAX-7]
  75   (assert (= (length (disasm 0 'foo)) 4)))
  76
  77 (defvar *blub*) ; immobile space
  78 (defvar blub)   ; dynamic space
  79 (assert (sb-kernel:immobile-space-obj-p '*blub*))
  80 #-immobile-symbols (assert (not (sb-kernel:immobile-space-obj-p 'blub)))
  81
  82 (with-test (:name :symeval-unknown-tls-index :skipped-on :immobile-symbols)
  83   ;; When symbol SC is immediate:
  84   ;;    8B142514A24C20     MOV EDX, [#x204CA214]    ; tls_index: *BLUB*
  85   ;;    498B1414           MOV RDX, [R12+RDX]
  86   ;;    83FA61             CMP EDX, 97
  87   ;;    480F44142518A24C20 CMOVEQ RDX, [#x204CA218] ; *BLUB*
  88   ;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
  89   (assert (= (length (disasm 0 '*blub*)) 4))
  90
  91   ;; When symbol SC is constant:
  92   ;;    488B05B3FFFFFF     MOV RAX, [RIP-77]          ; 'BLUB"
  93   ;;    8B50F5             MOV EDX, [RAX-11]
  94   ;;    498B1414           MOV RDX, [R12+RDX]
  95   ;;    83FA61             CMP EDX, 97
  96   ;;    480F4450F9         CMOVEQ RDX, [RAX-7]
  97   (assert (= (length (disasm 0 'blub)) 5)))
  98
  99 (with-test (:name :object-not-type-error-encoding)
 100   ;; There should not be a "MOV Rnn, #xSYMBOL" instruction
 101   ;; before the OBJECT-NOT-TYPE-ERROR.
 102   (let* ((lines
 103           (split-string
 104            (with-output-to-string (s)
 105             (let ((sb-disassem:*disassem-location-column-width* 0))
 106               (disassemble '(lambda (x) (the sb-assem:label x))
 107                            :stream s)))
 108            #\newline))
 109          (index
 110           (position "; error trap" lines :test 'search)))
 111     (assert (search "OBJECT-NOT-TYPE-ERROR" (nth (1+ index) lines)))
 112     (assert (search "; #<SB-KERNEL:LAYOUT for SB-ASSEM:LABEL" (nth (+ index 3) lines)))))
 113
 114 #+immobile-code
 115 (with-test (:name :reference-assembly-tramp)
 116   (dolist (testcase '(("FUNCALLABLE-INSTANCE-TRAMP"
 117                        sb-kernel:%make-funcallable-instance)
 118                       ("UNDEFINED-TRAMP"
 119                        sb-kernel:make-fdefn)))
 120     (let ((lines
 121            (split-string
 122             (with-output-to-string (stream)
 123               (let ((sb-disassem:*disassem-location-column-width* 0))
 124                 (disassemble (cadr testcase) :stream stream)))
 125             #\newline)))
 126       (assert (loop for line in lines
 127                     thereis (and (search "LEA" line)
 128                                  (search "RIP" line) ; require RIP-relative mode
 129                                  ;; and verify disassembly
 130                                  (search (car testcase) line)))))))
 131
 132 #+immobile-code
 133 (with-test (:name :static-unlinker)
 134   (let ((sb-c::*compile-to-memory-space* :immobile))
 135     (declare (muffle-conditions style-warning))
 136     (flet ((disassembly-lines (name)
 137              (split-string
 138               (with-output-to-string (s)
 139                 (let ((sb-disassem:*disassem-location-column-width* 0))
 140                   (disassemble name :stream s)))
 141               #\newline))
 142            (expect (match lines)
 143              (assert (loop for line in lines
 144                            thereis (search match line)))))
 145       (compile 'h '(lambda (x) (1+ x)))
 146       (setf (symbol-function 'g) #'h (symbol-function 'f) #'h)
 147       (compile 'c '(lambda (x) (g x)))
 148       (compile 'd '(lambda (x) (f (g x))))
 149       ;; The FDEFN-FUN of F is same as that of G.
 150       ;; Statically linking D should not patch the fdefn calls into static calls
 151       ;; because it can't unambiguously be undone without storing additional data
 152       ;; about where patches were performed to begin with.
 153       (sb-vm::statically-link-core :callers '(c d))
 154       (let ((lines (disassembly-lines 'c)))
 155         (expect "#<FUNCTION H>" lines))
 156       (let ((lines (disassembly-lines 'd)))
 157         (expect "#<FDEFN F>" lines)
 158         (expect "#<FDEFN G>" lines))
 159       (handler-bind ((warning #'muffle-warning))
 160         (defun g (x) (- x)))
 161       (let ((lines (disassembly-lines 'c)))
 162         (expect "#<FDEFN G>" lines)))))
 163
 164 (with-test (:name :c-call
 165             :broken-on (not :sb-dynamic-core))
 166   (let* ((lines (split-string
 167                  (with-output-to-string (s)
 168                    (let ((sb-disassem:*disassem-location-column-width* 0))
 169                      (disassemble 'sb-sys:deallocate-system-memory :stream s)))
 170                  #\newline))
 171          (c-call (find "os_deallocate" lines :test #'search)))
 172     ;; Depending on #+immobile-code it's either direct or memory indirect.
 173     #+immobile-code (assert (search "CALL #x" c-call))
 174     #-immobile-code (assert (search "CALL [#x" c-call))))