src/compiler/x86-64/target-insts.lisp

   1 ;;;; target-only stuff from CMU CL's src/compiler/x86/insts.lisp
   2 ;;;;
   3 ;;;; i.e. stuff which was in CMU CL's insts.lisp file, but which in
   4 ;;;; the SBCL build process can't be compiled into code for the
   5 ;;;; cross-compilation host
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!X86-64-ASM")
  17
  18 (defstruct (machine-ea (:include sb!disassem::filtered-arg)
  19                        (:copier nil)
  20                        (:predicate nil)
  21                        (:constructor %make-machine-ea))
  22   base disp index scale)
  23
  24 ;;; Print to STREAM the name of the general-purpose register encoded by
  25 ;;; VALUE and of size WIDTH. For robustness, the high byte registers
  26 ;;; (AH, BH, CH, DH) are correctly detected, too, although the compiler
  27 ;;; does not use them.
  28 (defun print-reg-with-width (value width stream dstate)
  29   (declare (type full-reg value)
  30            (type stream stream)
  31            (type disassem-state dstate))
  32   (princ (if (and (eq width :byte)
  33                   (<= 4 value 7)
  34                   (not (dstate-get-inst-prop dstate +rex+)))
  35              (aref #("AH" "CH" "DH" "BH") (- value 4))
  36              (aref (ecase width
  37                      (:byte sb!vm::+byte-register-names+)
  38                      (:word sb!vm::+word-register-names+)
  39                      (:dword sb!vm::+dword-register-names+)
  40                      (:qword sb!vm::+qword-register-names+))
  41                    value))
  42          stream)
  43   ;; XXX plus should do some source-var notes
  44   )
  45
  46 (defun print-reg (value stream dstate)
  47   (print-reg-with-width value
  48                         (inst-operand-size dstate)
  49                         stream
  50                         dstate))
  51
  52 (defun print-reg-default-qword (value stream dstate)
  53   (print-reg-with-width value
  54                         (inst-operand-size-default-qword dstate)
  55                         stream
  56                         dstate))
  57
  58 ;; Print a reg that can only be a :DWORD or :QWORD.
  59 ;; Avoid use of INST-OPERAND-SIZE because it's wrong for this type of operand.
  60 (defun print-d/q-word-reg (value stream dstate)
  61   (print-reg-with-width value
  62                         (if (dstate-get-inst-prop dstate +rex-w+) :qword :dword)
  63                         stream
  64                         dstate))
  65
  66 (defun print-byte-reg (value stream dstate)
  67   (print-reg-with-width value :byte stream dstate))
  68
  69 (defun print-addr-reg (value stream dstate)
  70   (print-reg-with-width value +default-address-size+ stream dstate))
  71
  72 ;;; Print a register or a memory reference of the given WIDTH.
  73 ;;; If SIZED-P is true, add an explicit size indicator for memory
  74 ;;; references.
  75 (defun print-reg/mem-with-width (value width sized-p stream dstate)
  76   (declare (type (or machine-ea full-reg) value)
  77            (type (member :byte :word :dword :qword) width)
  78            (type boolean sized-p))
  79   (if (typep value 'full-reg)
  80       (print-reg-with-width value width stream dstate)
  81       (print-mem-ref (if sized-p :sized-ref :ref) value width stream dstate)))
  82
  83 ;;; Print a register or a memory reference. The width is determined by
  84 ;;; calling INST-OPERAND-SIZE.
  85 (defun print-reg/mem (value stream dstate)
  86   (print-reg/mem-with-width
  87    value (inst-operand-size dstate) nil stream dstate))
  88
  89 ;; Same as print-reg/mem, but prints an explicit size indicator for
  90 ;; memory references.
  91 (defun print-sized-reg/mem (value stream dstate)
  92   (print-reg/mem-with-width
  93    value (inst-operand-size dstate) t stream dstate))
  94
  95 ;;; Same as print-sized-reg/mem, but with a default operand size of
  96 ;;; :qword.
  97 (defun print-sized-reg/mem-default-qword (value stream dstate)
  98   (print-reg/mem-with-width
  99    value (inst-operand-size-default-qword dstate) t stream dstate))
 100
 101 (defun print-sized-byte-reg/mem (value stream dstate)
 102   (print-reg/mem-with-width value :byte t stream dstate))
 103
 104 (defun print-sized-word-reg/mem (value stream dstate)
 105   (print-reg/mem-with-width value :word t stream dstate))
 106
 107 (defun print-sized-dword-reg/mem (value stream dstate)
 108   (print-reg/mem-with-width value :dword t stream dstate))
 109
 110 (defun print-label (value stream dstate)
 111   (declare (ignore dstate))
 112   (princ16 value stream))
 113
 114 (defun print-xmmreg (value stream dstate)
 115   (declare (type xmmreg value) (type stream stream) (ignore dstate))
 116   (format stream "XMM~d" value))
 117
 118 (defun print-xmmreg/mem (value stream dstate)
 119   (if (typep value 'xmmreg)
 120       (print-xmmreg value stream dstate)
 121       (print-mem-ref :ref value nil stream dstate)))
 122
 123 (defun print-imm/asm-routine (value stream dstate)
 124   (if (or #!+immobile-space (maybe-note-lisp-callee value dstate)
 125           (maybe-note-assembler-routine value nil dstate)
 126           (maybe-note-static-symbol value dstate))
 127       (write value :stream stream :base 16 :radix t)
 128       (princ value stream)))
 129
 130 ;;; Return either a MACHINE-EA or a register (a fixnum).
 131 ;;; MOD and R/M are the extracted bits from the instruction's ModRM byte.
 132 ;;; Depending on MOD and R/M, a SIB byte and/or displacement may be read.
 133 ;;; The REX.B and REX.X from dstate are appropriately consumed.
 134 (defun prefilter-reg/mem (dstate mod r/m)
 135   (declare (type disassem-state dstate)
 136            (type (unsigned-byte 2) mod)
 137            (type (unsigned-byte 3) r/m))
 138   (flet ((make-machine-ea (base &optional disp index scale)
 139            (let ((ea (the machine-ea
 140                        (sb!disassem::new-filtered-arg dstate #'%make-machine-ea))))
 141              (setf (machine-ea-base ea) base
 142                    (machine-ea-disp ea) disp
 143                    (machine-ea-index ea) index
 144                    (machine-ea-scale ea) scale)
 145              ea))
 146          (displacement ()
 147            (case mod
 148              (#b01 (read-signed-suffix 8 dstate))
 149              (#b10 (read-signed-suffix 32 dstate))))
 150          (extend (bit-name reg)
 151            (logior (if (dstate-get-inst-prop dstate bit-name) 8 0)
 152                    reg)))
 153     (declare (inline extend))
 154     (let ((full-reg (extend +rex-b+ r/m)))
 155       (cond ((= mod #b11) full-reg) ; register direct mode
 156             ((= r/m #b100) ; SIB byte - rex.b is "don't care"
 157              (let* ((sib (the (unsigned-byte 8) (read-suffix 8 dstate)))
 158                     (index-reg (extend +rex-x+ (ldb (byte 3 3) sib)))
 159                     (base-reg (ldb (byte 3 0) sib)))
 160                ;; mod=0 and base=RBP means no base reg
 161                (make-machine-ea (unless (and (= mod #b00) (= base-reg #b101))
 162                                   (extend +rex-b+ base-reg))
 163                                 (cond ((/= mod #b00) (displacement))
 164                                       ((= base-reg #b101) (read-signed-suffix 32 dstate)))
 165                                 (unless (= index-reg #b100) index-reg) ; index can't be RSP
 166                                 (ash 1 (ldb (byte 2 6) sib)))))
 167             ((/= mod #b00) (make-machine-ea full-reg (displacement)))
 168             ;; rex.b is not decoded in determining RIP-relative mode
 169             ((= r/m #b101) (make-machine-ea :rip (read-signed-suffix 32 dstate)))
 170             (t (make-machine-ea full-reg))))))
 171
 172 #!+sb-thread
 173 (defun static-symbol-from-tls-index (index)
 174   (dovector (sym +static-symbols+)
 175     (when (= (symbol-tls-index sym) index)
 176       (return sym))))
 177
 178 ;;; Prints a memory reference to STREAM. VALUE is a list of
 179 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component may be
 180 ;;; missing or nil to indicate that it's not used or has the obvious
 181 ;;; default value (e.g., 1 for the index-scale). BASE-REG can be the
 182 ;;; symbol RIP or a full register, INDEX-REG a full register. If WIDTH
 183 ;;; is non-nil it should be one of the symbols :BYTE, :WORD, :DWORD or
 184 ;;; :QWORD; a corresponding size indicator is printed if MODE is :SIZED-REF.
 185 ;;; The rationale for supplying WIDTH while eliding a pointer-size qualifier
 186 ;;; is that proper dereferencing of RIP-relative constants requires a size,
 187 ;;; but in other cases would only add clutter, since a source/destination
 188 ;;; register implies a size.
 189 ;;;
 190 (defun print-mem-ref (mode value width stream dstate)
 191   ;; :COMPUTE is used for the LEA instruction - it informs this function
 192   ;; that we're not loading from the address and that the contents should not
 193   ;; be printed. It'll usually be a reference to code within the disasembly
 194   ;; segment, as LEA is employed to compute the entry point for local call.
 195   (declare (type (member :ref :sized-ref :compute) mode)
 196            (type machine-ea value)
 197            (type (member nil :byte :word :dword :qword) width)
 198            (type stream stream)
 199            (type disassem-state dstate))
 200   (let ((base-reg (machine-ea-base value))
 201         (disp (machine-ea-disp value))
 202         (index-reg (machine-ea-index value))
 203         (firstp t))
 204     (when (and width (eq mode :sized-ref))
 205       (princ width stream)
 206       (princ '| PTR | stream))
 207     (write-char #\[ stream)
 208     (when base-reg
 209       (if (eql :rip base-reg)
 210           (princ base-reg stream)
 211           (print-addr-reg base-reg stream dstate))
 212       (setq firstp nil))
 213     (when index-reg
 214       (unless firstp (write-char #\+ stream))
 215       (print-addr-reg index-reg stream dstate)
 216       (let ((scale (machine-ea-scale value)))
 217         (unless (= scale 1)
 218           (write-char #\* stream)
 219           (princ scale stream)))
 220       (setq firstp nil))
 221     (when (and disp (or firstp (not (zerop disp))))
 222       (unless (or firstp (minusp disp))
 223         (write-char #\+ stream))
 224       (cond ((eq (machine-ea-base value) :rip)
 225              (princ disp stream)
 226              (unless (eq mode :compute)
 227                (let ((addr (+ disp (dstate-next-addr dstate))))
 228                  ;; The origin is zero when disassembling into a trace-file.
 229                  ;; Don't crash on account of it.
 230                  (when (plusp addr)
 231                    (or (nth-value
 232                         1 (note-code-constant-absolute addr dstate width))
 233                        (maybe-note-assembler-routine addr nil dstate)
 234                        ;; Show the absolute address and maybe the contents.
 235                        (note (format nil "[#x~x]~@[ = ~x~]"
 236                                      addr
 237                                      (case width
 238                                        (:qword
 239                                         (unboxed-constant-ref
 240                                          dstate
 241                                          (+ (dstate-next-offs dstate) disp)))))
 242                              dstate))))))
 243             (firstp
 244                (princ16 disp stream)
 245                (or (minusp disp)
 246                    (nth-value 1 (note-code-constant-absolute disp dstate))
 247                    (maybe-note-assembler-routine disp nil dstate)
 248                    ;; Static symbols coming frorm CELL-REF
 249                    (maybe-note-static-symbol (+ disp (- other-pointer-lowtag
 250                                                         n-word-bytes))
 251                                              dstate)))
 252             (t
 253              (princ disp stream))))
 254     (write-char #\] stream)
 255     #!+sb-thread
 256     (when (and (eql base-reg #.(ash (tn-offset sb!vm::thread-base-tn) -1))
 257                (not index-reg) ; no index
 258                (typep disp '(integer 0 *)) ; positive displacement
 259                (seg-code (dstate-segment dstate)))
 260       ;; Try to reverse-engineer which thread-local binding this is
 261       (let* ((code (seg-code (dstate-segment dstate)))
 262              (header-n-words (code-header-words code))
 263              (tls-index (ash disp (- n-fixnum-tag-bits)))
 264              (symbol
 265               (or (loop for word-num from code-constants-offset below header-n-words
 266                         for obj = (code-header-ref code word-num)
 267                         when (and (symbolp obj) (= (symbol-tls-index obj) tls-index))
 268                         do (return obj))
 269                   ;; static symbols with known TLS index don't go in the code header,
 270                   ;; but it'd be nice to guess at the symbol.
 271                   (static-symbol-from-tls-index tls-index))))
 272         (when symbol
 273           (return-from print-mem-ref
 274             (note (lambda (stream) (format stream "tls: ~S" symbol))
 275                   dstate))))
 276       ;; Or maybe we're looking at the 'struct thread' itself
 277       (when (< disp max-interrupts)
 278         (let* ((thread-slots
 279                 (load-time-value
 280                  (primitive-object-slots
 281                   (find 'sb!vm::thread *primitive-objects*
 282                         :key #'primitive-object-name)) t))
 283                (slot (find (ash disp (- word-shift)) thread-slots
 284                            :key #'slot-offset)))
 285           (when slot
 286             (return-from print-mem-ref
 287               (note (lambda (stream)
 288                       (format stream "thread.~(~A~)" (slot-name slot)))
 289                     dstate))))))))
 290
 291 (defun lea-compute-label (value dstate)
 292   ;; If VALUE should be regarded as a label, return the address.
 293   ;; If not, just return VALUE.
 294   (if (and (typep value 'machine-ea) (eq (machine-ea-base value) :rip))
 295       (+ (dstate-next-addr dstate) (machine-ea-disp value))
 296       value))
 297
 298 ;; Figure out whether LEA should print its EA with just the stuff in brackets,
 299 ;; or additionally show the EA as either a label or a hex literal.
 300 (defun lea-print-ea (value stream dstate)
 301   (let ((width (inst-operand-size dstate))
 302         (addr nil)
 303         (fmt "= #x~x"))
 304     (etypecase value
 305       (machine-ea
 306        ;; Indicate to PRINT-MEM-REF that this is not a memory access.
 307        (print-mem-ref :compute value width stream dstate)
 308        (when (eq (machine-ea-base value) :rip)
 309          (setq addr (+ (dstate-next-addr dstate) (machine-ea-disp value)))))
 310
 311       ;; We're robust in allowing VALUE to be an integer (a register),
 312       ;; though LEA Rx,Ry is an illegal instruction.
 313       ;; Test this before INTEGER since the types overlap.
 314       (full-reg
 315        (print-reg-with-width value width stream dstate))
 316
 317       ((or string integer)
 318        ;; A label for the EA should not print as itself, but as the decomposed
 319        ;; addressing mode so that [ADDR] and [RIP+disp] are unmistakable.
 320        ;; We can see an INTEGER here because LEA-COMPUTE-LABEL is always called
 321        ;; on the operand to LEA, and it will compute an absolute address based
 322        ;; off RIP when possible. If :use-labels NIL was specified, there is
 323        ;; no hashtable of address to string, so we get the address.
 324        ;; But ordinarily we get the string. Either way, the r/m arg reveals the
 325        ;; EA calculation. DCHUNK-ZERO is a meaningless value - any would do -
 326        ;; because the EA was computed in a prefilter.
 327        (print-mem-ref :compute (reg-r/m-inst-r/m-arg dchunk-zero dstate)
 328                       width stream dstate)
 329        (setq addr value)
 330        (when (stringp value) (setq fmt "= ~A"))))
 331     (when addr
 332       (note (lambda (s) (format s fmt addr)) dstate))))
 333
 334 (defun unboxed-constant-ref (dstate segment-offset)
 335   (let* ((seg (dstate-segment dstate))
 336          (code-offset
 337           (sb!disassem::segment-offs-to-code-offs segment-offset seg))
 338          (unboxed-range (sb!disassem::seg-unboxed-data-range seg)))
 339     (and unboxed-range
 340          (<= (car unboxed-range) code-offset (cdr unboxed-range))
 341          (sap-ref-int (dstate-segment-sap dstate)
 342                       segment-offset n-word-bytes
 343                       (dstate-byte-order dstate)))))
 344
 345 ;;;; interrupt instructions
 346
 347 (defun break-control (chunk inst stream dstate)
 348   (declare (ignore inst))
 349   (flet ((nt (x) (if stream (note x dstate))))
 350     (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
 351           #!+ud2-breakpoints (word-imm-code chunk dstate)
 352       (#.error-trap
 353        (nt "error trap")
 354        (handle-break-args #'snarf-error-junk stream dstate))
 355       (#.cerror-trap
 356        (nt "cerror trap")
 357        (handle-break-args #'snarf-error-junk stream dstate))
 358       (#.breakpoint-trap
 359        (nt "breakpoint trap"))
 360       (#.pending-interrupt-trap
 361        (nt "pending interrupt trap"))
 362       (#.halt-trap
 363        (nt "halt trap"))
 364       (#.fun-end-breakpoint-trap
 365        (nt "function end breakpoint trap"))
 366       (#.single-step-around-trap
 367        (nt "single-step trap (around)"))
 368       (#.single-step-before-trap
 369        (nt "single-step trap (before)"))
 370       (#.invalid-arg-count-trap
 371        (nt "Invalid argument count trap")))))
 372
 373 ;;;;
 374
 375 #!+immobile-code
 376 (progn
 377 (defun sb!vm::collect-immobile-code-relocs ()
 378   (let ((code-components
 379          (make-array 20000 :element-type '(unsigned-byte 32)
 380                            :fill-pointer 0 :adjustable t))
 381         (relocs
 382          (make-array 100000 :element-type '(unsigned-byte 32)
 383                             :fill-pointer 0 :adjustable t))
 384         ;; Look for these two instruction formats.
 385         (jmp-inst (find-inst #b11101001 (get-inst-space)))
 386         (call-inst (find-inst #b11101000 (get-inst-space)))
 387         (seg (sb!disassem::%make-segment
 388               :sap-maker #'error :virtual-location 0))
 389         (dstate (make-dstate)))
 390     (flet ((scan-function (fun-entry-addr fun-end-addr predicate)
 391              (setf (seg-virtual-location seg) fun-entry-addr
 392                    (seg-length seg) (- fun-end-addr fun-entry-addr)
 393                    (seg-sap-maker seg)
 394                    (let ((sap (int-sap fun-entry-addr))) (lambda () sap)))
 395              (map-segment-instructions
 396               (lambda (dchunk inst)
 397                 (when (and (or (eq inst jmp-inst)
 398                                (eq inst call-inst))
 399                            (funcall predicate
 400                                     (+ (near-jump-displacement dchunk dstate)
 401                                        (dstate-next-addr dstate))))
 402                   (vector-push-extend (dstate-cur-addr dstate) relocs)))
 403               seg dstate nil))
 404            (finish-component (code start-relocs-index)
 405              (when (> (fill-pointer relocs) start-relocs-index)
 406                (vector-push-extend (get-lisp-obj-address code) code-components)
 407                (vector-push-extend start-relocs-index code-components))))
 408
 409       ;; Assembler routines contain jumps to immobile code.
 410       ;; Since these code components do not contain simple-funs,
 411       ;; we have to group the routines by looking at addresses.
 412       (let ((asm-routines
 413              (loop for addr being each hash-value of sb!fasl:*assembler-routines*
 414                    collect addr)))
 415         (dovector (code sb!fasl::*assembler-objects*)
 416           (let* ((text-origin (sap-int (code-instructions code)))
 417                  (text-end (+ text-origin (%code-code-size code)))
 418                  (relocs-index (fill-pointer relocs)))
 419             (mapl (lambda (list)
 420                     (scan-function (car list)
 421                                    (if (cdr list) (cadr list) text-end)
 422                                    ;; Look for transfers into immobile code
 423                                    (lambda (jmp-targ-addr)
 424                                      (<= sb!vm:immobile-space-start
 425                                          jmp-targ-addr sb!vm:immobile-space-end))))
 426                   (sort (remove-if-not (lambda (address)
 427                                          (<= text-origin address text-end))
 428                                        asm-routines) #'<))
 429             (finish-component code relocs-index))))
 430
 431       ;; Immobile space - code components can jump to immobile space,
 432       ;; read-only space, and C runtime routines.
 433       (sb!vm::map-allocated-objects
 434        (lambda (code type size)
 435          (declare (ignore size))
 436          (when (= type code-header-widetag)
 437            (let* ((text-origin (sap-int (code-instructions code)))
 438                   (text-end (+ text-origin (%code-code-size code)))
 439                   (relocs-index (fill-pointer relocs)))
 440              (dotimes (i (code-n-entries code) (finish-component code relocs-index))
 441                (let ((fun (%code-entry-point code i)))
 442                  (scan-function
 443                   (+ (get-lisp-obj-address fun) (- fun-pointer-lowtag)
 444                      (ash simple-fun-code-offset word-shift))
 445                   (if (< (1+ i) (code-n-entries code))
 446                       (- (get-lisp-obj-address (%code-entry-point code (1+ i)))
 447                          fun-pointer-lowtag)
 448                       text-end)
 449                 ;; Exclude transfers within this code component
 450                   (lambda (jmp-targ-addr)
 451                     (not (<= text-origin jmp-targ-addr text-end)))))))))
 452        :immobile))
 453
 454     ;; Write a delimiter into the array passed to C
 455     (vector-push-extend 0 code-components)
 456     (vector-push-extend (fill-pointer relocs) code-components)
 457     (values code-components relocs)))
 458
 459 (defmacro do-immobile-functions ((code-var fun-var addr-var &key (if t)) &body body)
 460   ;; Loop over all code objects
 461   `(let* ((call (find-inst #xE8 (get-inst-space)))
 462           (jmp  (find-inst #xE9 (get-inst-space)))
 463           (dstate (make-dstate))
 464           (sap (int-sap 0))
 465           (seg (sb!disassem::%make-segment :sap-maker (lambda () sap))))
 466      (sb!vm::map-objects-in-range
 467       (lambda (,code-var obj-type obj-size)
 468         (declare (ignore obj-size))
 469         (when (and (= obj-type code-header-widetag) ,if)
 470           ;; Loop over all embedded functions
 471           (dotimes (fun-index (code-n-entries ,code-var))
 472             (let* ((,fun-var (%code-entry-point ,code-var fun-index))
 473                    (,addr-var (+ (get-lisp-obj-address ,fun-var)
 474                                  (- fun-pointer-lowtag)
 475                                  (ash simple-fun-code-offset word-shift))))
 476               (with-pinned-objects (sap) ; Mutate SAP to point to fun
 477                 (setf (sap-ref-word (int-sap (get-lisp-obj-address sap))
 478                                     (- n-word-bytes other-pointer-lowtag))
 479                       ,addr-var))
 480               (setf (seg-virtual-location seg) ,addr-var
 481                     (seg-length seg)
 482                     (- (let ((next (%code-entry-point ,code-var (1+ fun-index))))
 483                          (if next
 484                              (- (get-lisp-obj-address next) fun-pointer-lowtag)
 485                              (+ (sap-int (code-instructions ,code-var))
 486                                 (%code-code-size ,code-var))))
 487                        ,addr-var))
 488               ,@body))))
 489       ;; Slowness here is bothersome, especially for SB!VM::REMOVE-STATIC-LINKS,
 490       ;; so skip right over all fixedobj pages.
 491       (ash (+ immobile-space-start immobile-fixedobj-subspace-size)
 492            (- n-fixnum-tag-bits))
 493       (%make-lisp-obj (sap-int *immobile-space-free-pointer*)))))
 494
 495 (defun sb!vm::statically-link-core (&key callers exclude-callers
 496                                          callees exclude-callees
 497                                          verbose)
 498   (flet ((match-p (name include exclude)
 499            (and (not (member name exclude :test 'equal))
 500                 (or (not include) (member name include :test 'equal)))))
 501     (do-immobile-functions (code fun addr)
 502       (when (match-p (%simple-fun-name fun) callers exclude-callers)
 503         (let ((printed-fun-name nil))
 504           ;; Loop over function's assembly code
 505           (map-segment-instructions
 506            (lambda (chunk inst)
 507              (when (or (eq inst jmp) (eq inst call))
 508                (let ((fdefn (sb!vm::find-called-object
 509                              (+ (near-jump-displacement chunk dstate)
 510                                 (dstate-next-addr dstate)))))
 511                  (when (and (fdefn-p fdefn)
 512                             (let ((callee (fdefn-fun fdefn)))
 513                               (and (sb!kernel::immobile-space-obj-p callee)
 514                                    (not (sb!vm::fun-requires-simplifying-trampoline-p callee))
 515                                    (match-p (%fun-name callee)
 516                                             callees exclude-callees))))
 517                    (let ((entry (sb!vm::fdefn-call-target fdefn)))
 518                      (when verbose
 519                        (let ((*print-pretty* nil))
 520                          (unless printed-fun-name
 521                            (format t "#x~X ~S~%" (get-lisp-obj-address fun) fun)
 522                            (setq printed-fun-name t))
 523                          (format t "  @~x -> ~s [~x]~%"
 524                                  (dstate-cur-addr dstate) (fdefn-name fdefn) entry)))
 525                      ;; Set the statically-linked flag
 526                      (setf (sb!vm::fdefn-has-static-callers fdefn) 1)
 527                      ;; Change the machine instruction
 528                      (setf (signed-sap-ref-32 (int-sap (dstate-cur-addr dstate)) 1)
 529                            (- entry (dstate-next-addr dstate))))))))
 530            seg dstate))))))
 531
 532 ;;; While concurrent use of un-statically-link is unlikely, misuse could easily
 533 ;;; cause heap corruption. It's preventable by ensuring that this is atomic
 534 ;;; with respect to GC and other code attempting to change the same fdefn.
 535 ;;; The issue is that if the fdefn loses the pointer to the underlying code
 536 ;;; via (setf fdefn-fun) before we were done removing the static links,
 537 ;;; then there could be no remaining pointers visible to GC.
 538 ;;; The only way to detect the current set of references is to find uses of the
 539 ;;; current jump address, which means we need to fix them *all* before anyone
 540 ;;; else gets an opportunity to change the fdefn-fun of this same fdefn again.
 541 (defglobal *static-linker-lock* (sb!thread:make-mutex :name "static linker"))
 542 (defun sb!vm::remove-static-links (fdefn)
 543   ; (warn "undoing static linkage of ~S" (fdefn-name fdefn))
 544   (sb!thread::with-system-mutex (*static-linker-lock* :without-gcing t)
 545     ;; If the jump is to FUN-ENTRY, change it back to FDEFN-ENTRY
 546     (let ((fun-entry (sb!vm::fdefn-call-target fdefn))
 547           (fdefn-entry (+ (get-lisp-obj-address fdefn)
 548                           (ash fdefn-raw-addr-slot word-shift)
 549                           (- other-pointer-lowtag))))
 550       ;; Examine only those code components which potentially use FDEFN.
 551       (do-immobile-functions
 552          (code fun addr :if (loop for i downfrom (1- (sb!kernel:code-header-words code))
 553                                   to sb!vm:code-constants-offset
 554                                   thereis (eq (sb!kernel:code-header-ref code i)
 555                                               fdefn)))
 556         (map-segment-instructions
 557          (lambda (chunk inst)
 558            (when (or (eq inst jmp) (eq inst call))
 559              ;; TRULY-THE because near-jump-displacement isn't a known fun.
 560              (let ((disp (truly-the (signed-byte 32)
 561                                     (near-jump-displacement chunk dstate))))
 562                (when (= fun-entry (+ disp (dstate-next-addr dstate)))
 563                  (let ((new-disp
 564                         (the (signed-byte 32)
 565                              (- fdefn-entry (dstate-next-addr dstate)))))
 566                    ;; CMPXCHG is atomic even when misaligned, and x86-64 promises
 567                    ;; that self-modifying code works correctly, so the fetcher
 568                    ;; should never see a torn write.
 569                    (%primitive sb!vm::signed-sap-cas-32
 570                                (int-sap (dstate-cur-addr dstate))
 571                                1 disp new-disp))))))
 572          seg dstate)))
 573     (setf (sb!vm::fdefn-has-static-callers fdefn) 0))) ; Clear static link flag
 574 ) ; end PROGN