x86-64: Prefer RIP-relative mode for accessing assembly tramps

More work to defrag, but less work to relocate spaces
(in reality there are < 1 dozen affected instructions)

However, the win is that intra-varyobj-space opaque pointers (ones not seen
by GC) are all space-relative, so as long as fixedobj space does not need
relocation, the varyobj space can move anywhere with no fixups internal to
that space. We must fix pointers into it of course.

src/compiler/x86-64/alloc.lisp

@@ -364,8 +364,10 @@
   (:args)
   (:results (result :scs (any-reg)))
   (:generator 1
-    ;; TODO: if in immobile space, use LEA to make position-independent
-    (inst mov result (make-fixup 'funcallable-instance-tramp :assembly-routine))))
+    (let ((tramp (make-fixup 'funcallable-instance-tramp :assembly-routine)))
+      (if sb!c::*code-is-immobile*
+          (inst lea result tramp)
+          (inst mov result tramp)))))
 
 (define-vop (fixed-alloc)
   (:args)

src/compiler/x86-64/cell.lisp

@@ -389,9 +389,10 @@
   #!+immobile-code (:temporary (:sc unsigned-reg) temp)
   (:generator 38
     #!+immobile-code
-    (progn
-     (inst mov (reg-in-size temp :dword)
-           (make-fixup 'undefined-tramp :assembly-routine))
+    (let ((tramp (make-fixup 'undefined-tramp :assembly-routine)))
+     (if sb!c::*code-is-immobile*
+         (inst lea temp tramp)
+         (inst mov temp tramp))
      ;; Compute displacement from the call site
      (inst sub (reg-in-size temp :dword) (reg-in-size fdefn :dword))
      (inst sub (reg-in-size temp :dword)

src/compiler/x86-64/insts.lisp

@@ -1744,7 +1744,13 @@
    (maybe-emit-rex-for-ea segment src dst
                           :operand-size (if (dword-reg-p dst) :dword :qword))
    (emit-byte segment #b10001101)
-   (emit-ea segment src (reg-tn-encoding dst))))
+   (cond ((and (fixup-p src)
+               (eq (fixup-flavor src) :assembly-routine)
+               sb!c::*code-is-immobile*)
+          (emit-mod-reg-r/m-byte segment #b00 (reg-tn-encoding dst) #b101)
+          (emit-relative-fixup segment src))
+         (t
+          (emit-ea segment src (reg-tn-encoding dst))))))
 
 (define-instruction cmpxchg (segment dst src &optional prefix)
   ;; Register/Memory with Register.

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

@@ -389,7 +389,8 @@
        (setq addr value)
        (when (stringp value) (setq fmt "= ~A"))))
     (when addr
-      (note (lambda (s) (format s fmt addr)) dstate))))
+      (unless (maybe-note-assembler-routine addr nil dstate)
+        (note (lambda (s) (format s fmt addr)) dstate)))))
 
 ;;;; interrupt instructions
 
@@ -430,7 +431,8 @@
         (relocs
          (make-array 100000 :element-type '(unsigned-byte 32)
                             :fill-pointer 0 :adjustable t))
-        ;; Look for these two instruction formats.
+        ;; Look for these three instruction formats.
+        (lea-inst (find-inst #x8D (get-inst-space)))
         (jmp-inst (find-inst #b11101001 (get-inst-space)))
         (call-inst (find-inst #b11101000 (get-inst-space)))
         (seg (sb!disassem::%make-segment
@@ -443,12 +445,23 @@
                    (let ((sap (int-sap fun-entry-addr))) (lambda () sap)))
              (map-segment-instructions
               (lambda (dchunk inst)
-                (when (and (or (eq inst jmp-inst)
-                               (eq inst call-inst))
-                           (funcall predicate
-                                    (+ (near-jump-displacement dchunk dstate)
-                                       (dstate-next-addr dstate))))
-                  (vector-push-extend (dstate-cur-addr dstate) relocs)))
+                (cond ((and (or (eq inst jmp-inst) (eq inst call-inst))
+                            (funcall predicate
+                                     (+ (near-jump-displacement dchunk dstate)
+                                        (dstate-next-addr dstate))))
+                       (vector-push-extend (dstate-cur-addr dstate) relocs))
+                      ((eq inst lea-inst)
+                       (let ((sap (funcall (seg-sap-maker seg))))
+                         (aver (eql (sap-ref-8 sap (dstate-cur-offs dstate)) #x8D))
+                         (let ((modrm (sap-ref-8 sap (1+ (dstate-cur-offs dstate)))))
+                           (when (and (= (logand modrm #b11000111) #b00000101) ; RIP-relative mode
+                                      (funcall predicate
+                                               (+ (signed-sap-ref-32
+                                                   sap (+ (dstate-cur-offs dstate) 2))
+                                                  (dstate-next-addr dstate))))
+                             (aver (eql (logand (sap-ref-8 sap (1- (dstate-cur-offs dstate))) #xF0)
+                                        #x40)) ; expect a REX prefix
+                             (vector-push-extend (dstate-cur-addr dstate) relocs)))))))
               seg dstate nil))
            (finish-component (code start-relocs-index)
              (when (> (fill-pointer relocs) start-relocs-index)

src/runtime/immobile-space.c

@@ -1292,7 +1292,7 @@ void immobile_space_coreparse(uword_t fixedobj_len, uword_t varyobj_len)
         lispobj* __attribute__((unused)) padded_end = limit + size;
         gc_assert(!((uword_t)padded_end & (IMMOBILE_CARD_BYTES-1)));
     }
-    // Write-protect the pages occupied by the core file.
+    // Set the WP bits for pages occupied by the core file.
     // (There can be no inter-generation pointers.)
     if (ENABLE_PAGE_PROTECTION) {
         low_page_index_t page;
@@ -2131,7 +2131,7 @@ void defrag_immobile_space(int* components, boolean verbose)
 #endif  /* DEFRAGMENT_FIXEDOBJ_SUBSPACE */
 
 #ifdef LISP_FEATURE_X86_64
-    // Fix displacements in JMP and CALL instructions in code objects.
+    // Fix displacements in JMP, CALL, and LEA instructions in code objects.
     // There are 2 arrays in use:
     //  - the relocs[] array contains the address of any machine instruction
     //    that needs to be altered on account of space relocation.
@@ -2153,9 +2153,15 @@ void defrag_immobile_space(int* components, boolean verbose)
         int end_reloc_index = immobile_space_reloc_index[i*2+3];
         for ( ; reloc_index < end_reloc_index ; ++reloc_index ) {
             unsigned char* inst_addr = (unsigned char*)(long)immobile_space_relocs[reloc_index];
-            gc_assert(*inst_addr == 0xE8 || *inst_addr == 0xE9);
+            int inst_len = 5, // number of bytes in the instruction's encoding
+                inst_byte_num = 1; // where the displacement operand starts
+            switch (*inst_addr) { // opcode
+            case 0xE8: case 0xE9: break; // JMP or CALL
+            case 0x8D: inst_len = 6; inst_byte_num = 2; break; // LEA
+            default: lose("Can't fixup opcode %02x", *inst_addr);
+            }
             unsigned int target_addr =
-                (int)(long)inst_addr + 5 + (int)UNALIGNED_LOAD32(inst_addr+1);
+                (int)(long)inst_addr + inst_len + (int)UNALIGNED_LOAD32(inst_addr+inst_byte_num);
             int target_adjust = 0;
             // Both this code and the jumped-to code can move.
             // For this component, adjust by the displacement by (old - new).
@@ -2177,7 +2183,7 @@ void defrag_immobile_space(int* components, boolean verbose)
             // Otherwise perform the fixup where the instruction is now.
             char* fixup_loc = (immobile_space_p((lispobj)inst_addr) ?
                                (char*)tempspace_addr(inst_addr - code + load_addr) :
-                               (char*)inst_addr) + 1;
+                               (char*)inst_addr) + inst_byte_num;
             UNALIGNED_STORE32(fixup_loc,
                               UNALIGNED_LOAD32(fixup_loc)
                                 + target_adjust + (code - load_addr));

tests/x86-64-codegen.impure.lisp

@@ -108,3 +108,21 @@
           (position "; error trap" lines :test 'search)))
     (assert (search "OBJECT-NOT-TYPE-ERROR" (nth (1+ index) lines)))
     (assert (search "; 'SB-ASSEM:LABEL" (nth (+ index 3) lines)))))
+
+#+immobile-code
+(with-test (:name :reference-assembly-tramp)
+  (dolist (testcase '(("FUNCALLABLE-INSTANCE-TRAMP"
+                       sb-kernel:%make-funcallable-instance)
+                      ("UNDEFINED-TRAMP"
+                       sb-kernel:make-fdefn)))
+    (let ((lines
+           (split-string
+            (with-output-to-string (stream)
+              (let ((sb-disassem:*disassem-location-column-width* 0))
+                (disassemble (cadr testcase) :stream stream)))
+            #\newline)))
+      (assert (loop for line in lines
+                    thereis (and (search "LEA" line)
+                                 (search "RIP" line) ; require RIP-relative mode
+                                 ;; and verify disassembly
+                                 (search (car testcase) line)))))))