x86-64: Create fewer absolute fixups from dynamic space

src/assembly/x86-64/support.lisp

@@ -14,11 +14,24 @@
       (floor (+ feature-bit n-fixnum-tag-bits) n-byte-bits)
     (inst test :byte (static-symbol-value-ea '*cpu-feature-bits* byte) (ash 1 bit))))
 
-(defun invoke-asm-routine (inst routine vop)
+(defun uniquify-fixup (name &aux (asmstream *asmstream*))
+  (or (cdr (assoc name (sb-assem::asmstream-indirection-table asmstream)))
+      (let ((label (gen-label)))
+        ;; This has to be separate from the :ELSEWHERE section because we could be
+        ;; emitting code into :ELSEWHERE when requesting a unique label.
+        (assemble (:indirections)
+          (emit-label label)
+          (inst jmp (ea (make-fixup name :assembly-routine*))))
+        (push (cons name label) (sb-assem::asmstream-indirection-table asmstream))
+        label)))
+
+(defun invoke-asm-routine (inst routine vop &optional uniquify)
   (declare (ignorable vop))
   (let ((fixup
          (cond ((sb-c::code-immobile-p vop)
                 (make-fixup routine :assembly-routine))
+               (uniquify
+                (uniquify-fixup routine))
                (t
                 (ea (make-fixup routine :assembly-routine*))))))
     (ecase inst

src/compiler/assem.lisp

@@ -319,6 +319,7 @@
 
 (defstruct asmstream
   (data-section (make-section) :read-only t)
+  (indirections-section (make-section) :read-only t)
   (code-section (make-section) :read-only t)
   (elsewhere-section (make-section) :read-only t)
   (data-origin-label (gen-label "data start") :read-only t)
@@ -332,6 +333,11 @@
   ;; for deterministic allocation profiler (or possibly other tooling)
   ;; that wants to monkey patch the instructions at runtime.
   (alloc-points)
+  ;; for shrinking the size of the code fixups, we can choose to emit at most one call
+  ;; from a dynamic space code component to a given assembly routine. The call goes
+  ;; through an extra indirection in the component.
+  ;; This table is stored as an alist of (NAME . LABEL).
+  (indirection-table)
   ;; tracking where we last wrote an instruction so that SB-C::TRACE-INSTRUCTION
   ;; can print "in the {x} section" whenever it changes.
   (tracing-state (list nil nil) :read-only t)) ; segment and vop
@@ -448,6 +454,8 @@
                      ,(case dest
                         (:code '(asmstream-code-section *asmstream*))
                         (:elsewhere '(asmstream-elsewhere-section *asmstream*))
+                        (:indirections
+                         '(asmstream-indirections-section *asmstream*))
                         (t dest)))))
               ,@(when vop `((*current-vop* ,vop)))
               ,@(mapcar (lambda (name)
@@ -1494,8 +1502,10 @@
          (end-text (gen-label))
          (combined
            (append-sections
-             (append-sections (asmstream-data-section asmstream)
-                              (asmstream-code-section asmstream))
+            (append-sections (asmstream-data-section asmstream)
+                             (append-sections
+                              (asmstream-code-section asmstream)
+                              (asmstream-indirections-section asmstream)))
              (let ((section (asmstream-elsewhere-section asmstream)))
                (emit section
                      end-text

src/compiler/x86-64/alloc.lisp

@@ -93,7 +93,7 @@
                         (if to-r11
                             (if consp 'cons->r11 'alloc->r11)
                             (if consp 'cons->rnn 'alloc->rnn))
-                        node)
+                        node t)
     (unless to-r11
       (inst pop result-tn)))
   (unless (eql lowtag 0)
@@ -177,18 +177,17 @@
       (let ((helper (if (integerp size)
                         'enable-alloc-counter
                         'enable-sized-alloc-counter)))
-        (cond ((or (not node) ; assembly routine
-                   (sb-c::code-immobile-p node))
-               (inst call (make-fixup helper :assembly-routine)) ; 5 bytes
-               (emit-alignment 3 :long-nop))
-              (t
-               (inst call (ea (make-fixup helper :assembly-routine*))) ; 7 bytes
-               (inst nop))) ; align
-        (unless (integerp size)
-          ;; This TEST instruction is never executed- it informs the profiler
-          ;; which register holds SIZE.
-          (inst test size size) ; 3 bytes
-          (emit-alignment 3 :long-nop)))
+        ;; This jump is always encoded as 5 bytes
+        (inst call (if (or (not node) ; assembly routine
+                           (sb-c::code-immobile-p node))
+                       (make-fixup helper :assembly-routine)
+                       (uniquify-fixup helper))))
+      (emit-alignment 3 :long-nop)
+      (unless (integerp size)
+        ;; This TEST instruction is never executed- it informs the profiler
+        ;; which register holds SIZE.
+        (inst test size size) ; 3 bytes
+        (emit-alignment 3 :long-nop))
       (emit-label skip-instrumentation))))
 
 ;;; Emit code to allocate an object with a size in bytes given by

tests/x86-64-codegen.impure.lisp

@@ -1073,3 +1073,13 @@ sb-vm::(define-vop (cl-user::test)
              (let ((*print-length* nil))
                (format t "h1=~s~%h2=~s~%" h1 h2)
                (error "Error on n-elements = ~d" n-elements)))))))
+
+(with-test (:name :uniquify-fixups)
+  (let* ((f (let ((sb-c::*compile-to-memory-space* :dynamic))
+              (compile nil
+                       '(lambda (x)
+                         `(,(list 1 2) ,(cons 1 2) ,(list nil x) ,(list '(a) #\x))))))
+         (fixups
+          (sb-c::unpack-code-fixup-locs
+           (sb-vm::%code-fixups (sb-kernel:fun-code-header f)))))
+    (assert (<= (length fixups) 2))))