src/code/text-space.lisp

   1 ;;;; Reorganization of immobile code space.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-X86-64-ASM")
  13
  14 (eval-when (:compile-toplevel) ; not needed outside this file
  15 (defmacro do-text-space-code ((code-var) &body body)
  16   ;; Loop over all code objects
  17   `(let* ((call (find-inst #xE8 (get-inst-space)))
  18           (jmp  (find-inst #xE9 (get-inst-space)))
  19           (mov-ea (find-inst #x8B (get-inst-space)))
  20           (mov-imm-acc (find-inst #xB8 (get-inst-space)))
  21           (dstate (make-dstate nil))
  22           (sap (int-sap 0))
  23           (seg (sb-disassem::%make-segment :sap-maker (lambda () sap))))
  24      (declare (ignorable mov-ea mov-imm-acc))
  25      (macrolet ((do-functions ((fun-var addr-var) &body body)
  26                   ;; Loop over all embedded functions
  27                   `(dotimes (fun-index (code-n-entries ,',code-var))
  28                      (let* ((,fun-var (%code-entry-point ,',code-var fun-index))
  29                             (,addr-var (+ (get-lisp-obj-address ,fun-var)
  30                                           (- fun-pointer-lowtag)
  31                                           (ash simple-fun-insts-offset word-shift))))
  32                        (with-pinned-objects (sap) ; Mutate SAP to point to fun
  33                          (setf (sap-ref-word (int-sap (get-lisp-obj-address sap))
  34                                              (- n-word-bytes other-pointer-lowtag))
  35                                ,addr-var))
  36                        (setf (seg-virtual-location seg) ,addr-var
  37                              (seg-length seg) (%simple-fun-text-len ,fun-var fun-index))
  38                        ,@body))))
  39        (sb-vm::map-objects-in-range
  40         (lambda (,code-var obj-type obj-size)
  41           (declare (ignore obj-size))
  42           (when (= obj-type code-header-widetag) ,@body))
  43         ;; Slowness here is bothersome, especially for UNDO-STATIC-LINKAGE,
  44         ;; so skip right over all fixedobj pages.
  45         (ash text-space-start (- n-fixnum-tag-bits))
  46         (%make-lisp-obj (sap-int *text-space-free-pointer*)))))))
  47
  48 #+immobile-code
  49 (defun sb-vm::collect-immobile-code-relocs ()
  50   (let ((code-components
  51          (make-array 20000 :element-type 'sb-vm:word :fill-pointer 0 :adjustable t))
  52         (relocs
  53          (make-array 100000 :element-type 'sb-vm:word :fill-pointer 0 :adjustable t))
  54         (seg (sb-disassem::%make-segment
  55               :sap-maker (lambda () (error "Bad sap maker")) :virtual-location 0))
  56         (dstate (make-dstate nil)))
  57     (flet ((scan-function (code sap length extra-offset predicate)
  58              ;; Extra offset is the amount to add to the offset supplied in the
  59              ;; lambda to compute the instruction offset relative to the code base.
  60              ;; Defrag has already stuffed in forwarding pointers when it reads
  61              ;; this data, which makes code_header_words() inconvenient to use.
  62              (sb-x86-64-asm::scan-relative-operands
  63               code (sap-int sap) length dstate seg
  64               (lambda (offset operand inst)
  65                 (declare (ignore inst))
  66                 (let ((lispobj (if (immobile-space-addr-p operand)
  67                                    (sb-vm::find-called-object operand)
  68                                    0)))
  69                   (vector-push-extend (+ offset extra-offset) relocs)
  70                   (vector-push-extend (get-lisp-obj-address lispobj) relocs)))
  71                predicate))
  72            (finish-component (code start-relocs-index)
  73              (when (> (fill-pointer relocs) start-relocs-index)
  74                (vector-push-extend (get-lisp-obj-address code) code-components)
  75                (vector-push-extend start-relocs-index code-components))))
  76
  77       ;; Assembler routines contain jumps to immobile code.
  78       (let ((code sb-fasl:*assembler-routines*)
  79             (relocs-index (fill-pointer relocs)))
  80         ;; The whole thing can be disassembled in one stroke since inter-routine
  81         ;; gaps are encoded as NOPs.
  82         (multiple-value-bind (start end) (sb-fasl::calc-asm-routine-bounds)
  83           (scan-function code
  84                          (sap+ (code-instructions code) start)
  85                          (- end start)
  86                          ;; extra offset = header words + start
  87                          (+ (ash (code-header-words code) word-shift) start)
  88                          ;; calls from lisp into C code can be ignored, as
  89                          ;; neither the asssembly routines nor C code will move.
  90                          #'immobile-space-addr-p))
  91         (finish-component code relocs-index))
  92
  93       ;; Immobile space - code components can jump to immobile space,
  94       ;; read-only space, and C runtime routines.
  95       (sb-vm:map-allocated-objects
  96        (lambda (code type size)
  97          (declare (ignore size))
  98          (when (and (= type code-header-widetag) (plusp (code-n-entries code)))
  99            (let ((relocs-index (fill-pointer relocs)))
 100              (dotimes (i (code-n-entries code))
 101                ;; simple-funs must be individually scanned so that the
 102                ;; embedded boxed words are properly skipped over.
 103                (let* ((fun (%code-entry-point code i))
 104                       (sap (simple-fun-entry-sap fun)))
 105                  (scan-function code sap
 106                                 (%simple-fun-text-len fun i)
 107                                 ;; Compute the offset from the base of the code
 108                                 (+ (ash (code-header-words code) word-shift)
 109                                    (sap- sap (code-instructions code)))
 110                                 #'constantly-t)))
 111              (finish-component code relocs-index))))
 112        :immobile))
 113
 114     ;; Write a delimiter into the array passed to C
 115     (vector-push-extend 0 code-components)
 116     (vector-push-extend (fill-pointer relocs) code-components)
 117     (values code-components relocs)))
 118
 119 (export 'sb-vm::statically-link-core "SB-VM")
 120 (declaim (inline rip-relative-p))
 121 (defun rip-relative-p (modrm-byte) (= (logand modrm-byte #b11000111) #b00000101))
 122
 123 #+immobile-code
 124 (defun sb-vm::statically-link-core (&key callers)
 125   (do-text-space-code (code)
 126     (when (or (not callers)
 127               (and (plusp (code-n-entries code))
 128                    (member (%simple-fun-name (%code-entry-point code 0)) callers)))
 129       (let* ((fixups)
 130              (all-fdefns
 131               (do ((i sb-vm:code-constants-offset (1+ i))
 132                    (end (code-header-words code))
 133                    (list))
 134                   ((= i end) list)
 135                 (let ((const (code-header-ref code i)))
 136                   (typecase const
 137                     (fdefn (push const list))
 138                     ;; CONS may occur due to previous invocation of statically-link.
 139                     ((cons fdefn) (push (car const) list))))))
 140              (observable-fdefns) ; ones that an instruction explicitly dereferences
 141              (code-begin (- (get-lisp-obj-address code) sb-vm:other-pointer-lowtag))
 142              (code-end (+ code-begin (sb-vm::code-object-size code)))
 143              (boxed-begin (+ code-begin (* sb-vm:code-constants-offset sb-vm:n-word-bytes)))
 144              (boxed-end (+ code-begin (* (code-header-words code) sb-vm:n-word-bytes)))
 145              (code-insts (code-instructions code)))
 146         (do-functions (fun addr)
 147           ;; Loop over function's assembly code
 148           (dx-flet ((process-inst (chunk inst)
 149                       (cond
 150                         ;; find FDEFNs as the source of move-immediate-to-register.
 151                         ;; There can be false positives, but that's OK.
 152                         ((and (eq inst mov-imm-acc)
 153                               ;; ensure not a 64-bit move
 154                               (eql (sb-disassem::dstate-inst-properties dstate) 0))
 155                          (let ((value (sap-ref-32 sap (1+ (dstate-cur-offs dstate)))))
 156                            (dolist (fdefn all-fdefns)
 157                              (when (eql (get-lisp-obj-address fdefn) value)
 158                                (pushnew fdefn observable-fdefns)))))
 159                         ;; find FDEFNs in code header as the source of MOV EA to register
 160                         ((and (eq inst mov-ea)
 161                               (eql (sap-ref-8 sap (dstate-cur-offs dstate)) #x8B)
 162                               (rip-relative-p (sap-ref-8 sap (1+ (dstate-cur-offs dstate)))))
 163                          (let ((addr (+ (signed-sap-ref-32 sap (+ (dstate-cur-offs dstate) 2))
 164                                         (dstate-next-addr dstate))))
 165                            (when (and (not (logtest addr (ash sb-vm:lowtag-mask -1))) ; aligned
 166                                       (<= boxed-begin addr) (< addr boxed-end))
 167                              (let ((const (sap-ref-lispobj (int-sap addr) 0)))
 168                                (when (fdefn-p const)
 169                                  (pushnew const observable-fdefns))))))
 170                         ;; find FDEFN as the target of JMP/CALL
 171                         ((or (eq inst jmp) (eq inst call))
 172                          (let ((target (+ (near-jump-displacement chunk dstate)
 173                                           (dstate-next-addr dstate))))
 174                            ;; Can't be an FDEFN if within the same code object
 175                            (unless (and (<= code-begin target) (< target code-end))
 176                              (let ((fdefn (dolist (fdefn all-fdefns)
 177                                             (when (= target (+ (get-lisp-obj-address fdefn)
 178                                                                ;; KLUDGE: 2 = address of 'jmp' inst
 179                                                                (- 2 other-pointer-lowtag)))
 180                                               (return fdefn)))))
 181                                (when (and fdefn (neq (info :function :inlinep (fdefn-name fdefn))
 182                                                      'notinline))
 183                                  (push (cons (+ (sap- sap code-insts)
 184                                                 (1+ (sb-disassem:dstate-cur-offs dstate)))
 185                                              fdefn)
 186                                        fixups)))))))))
 187             (map-segment-instructions #'process-inst seg dstate)))
 188         (sb-vm::statically-link-code-obj code fixups observable-fdefns)))))
 189
 190 ;;; While concurrent use of un-statically-link is unlikely, misuse could easily
 191 ;;; cause heap corruption. It's preventable by ensuring that this is atomic
 192 ;;; with respect to other mutations of the same fdefn.
 193 ;;; The issue is that if the fdefn loses the pointer to the underlying code
 194 ;;; via (setf fdefn-fun) before we were done removing the static links,
 195 ;;; then there could be no remaining pointers visible to GC.
 196 ;;; The only way to detect the current set of references is to find uses of the
 197 ;;; current jump address, which means we need to fix them *all* before anyone
 198 ;;; else gets an opportunity to change the fdefn-fun of this same fdefn again.
 199 (defun sb-impl::undo-static-linkage (fdefn &aux (fun-entry (sb-vm::fdefn-raw-addr fdefn)))
 200   (unless (sb-vm::fdefn-has-static-callers fdefn)
 201     (return-from sb-impl::undo-static-linkage))
 202   (sb-int:with-system-mutex (sb-vm::*static-linker-lock*)
 203     (do-text-space-code (code)
 204       ;; Examine only those code components which potentially use FDEFN.
 205       (binding* ((fdefn-index
 206                   (multiple-value-bind (fdefns-start count) (code-header-fdefn-range code)
 207                     (dotimes (i count)
 208                       (let ((constant (code-header-ref code (+ fdefns-start i))))
 209                         (when (or (eq constant fdefn)
 210                                   (and (consp constant) (eq (car constant) fdefn)))
 211                           (return (+ fdefns-start i))))))
 212                   :exit-if-null))
 213         #-immobile-code
 214         (let ((header-slot-addr
 215                (+ (get-lisp-obj-address code)
 216                   (- (ash fdefn-index word-shift) other-pointer-lowtag))))
 217           (do-functions (fun addr)
 218             (map-segment-instructions
 219              (lambda (chunk inst)
 220                (when (or (eq inst jmp) (eq inst call))
 221                  ;; If the jump is to FUN-ENTRY, rewrite this call into
 222                  ;; MOV RAX,[RIP-n] ; CALL [RAX+9]
 223                  (let ((disp (truly-the (signed-byte 32) (near-jump-displacement chunk dstate))))
 224                    (when (= (+ disp (dstate-next-addr dstate)) fun-entry)
 225                      ;; 5 bytes prior has to be the start of a 5-byte NOP.
 226                      ;; Just trust that it is that.
 227                      (let ((sap (sap+ (int-sap (dstate-cur-addr dstate)) -5)))
 228                        (setf (sap-ref-8 sap 0) #x48
 229                              (sap-ref-8 sap 1) #x8B
 230                              (sap-ref-8 sap 2) #x05
 231                              (signed-sap-ref-32 sap 3)
 232                              (- 3 (- (dstate-next-addr dstate) header-slot-addr))
 233                              (sap-ref-8 sap 7) #xFF
 234                              (sap-ref-8 sap 8) (if (eq inst jmp) #x60 #x50)
 235                              (sap-ref-8 sap 9) 9))))))
 236              seg dstate)))
 237         #+immobile-code
 238         (flet ((fix (sap oldval)
 239                  (let* ((fdefn-entry (sb-vm::fdefn-entry-address fdefn))
 240                         (newval (the (signed-byte 32)
 241                                      (- fdefn-entry (sap-int (sap+ sap 4))))))
 242                    ;; CMPXCHG is atomic even when misaligned, and x86-64 promises
 243                    ;; that self-modifying code works correctly, so the fetcher
 244                    ;; should never see a torn write.
 245                    (cas (sap-ref-32 sap 0)
 246                         (ldb (byte 32 0) oldval)
 247                         (ldb (byte 32 0) newval)))))
 248           (let ((constant (code-header-ref code fdefn-index)))
 249             (setf (code-header-ref code fdefn-index) fdefn)
 250             (if (listp constant) ; list of saved fixup offsets
 251                 (dolist (offset (cdr constant))
 252                   (let ((sap (sap+ (code-instructions code) offset)))
 253                     (fix sap (signed-sap-ref-32 sap 0))))
 254                 (do-functions (fun addr)
 255                   (map-segment-instructions
 256                    (lambda (chunk inst)
 257                      (when (or (eq inst jmp) (eq inst call))
 258                        ;; If the jump is to FUN-ENTRY, change it back to FDEFN-ENTRY
 259                        ;; TRULY-THE because near-jump-displacement isn't a known fun.
 260                        (let ((disp (truly-the (signed-byte 32)
 261                                               (near-jump-displacement chunk dstate))))
 262                          (when (= (+ disp (dstate-next-addr dstate)) fun-entry)
 263                            (fix (sap+ (int-sap (dstate-cur-addr dstate)) 1) disp)))))
 264                    seg dstate)))))))
 265     (sb-vm::set-fdefn-has-static-callers fdefn 0)))