Add :IMMOBILE-CODE feature.

This is part 3 of 4 of the immobile space feature suite.
Supported only on x86-64 for macOS and Linux.

Includes some important bugfixes to the mark-and-sweep collector
that seemed not to be triggered except by immobile code.

NEWS

@@ -1,6 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
 changes relative to sbcl-1.3.11:
+  * enhancement: on x86-64, compiled functions can not be moved (but can
+    be freed) by GC. This facilitates examination of running images by
+    external tools. Code locality and performance are improved as well.
   * bug fix: calling a named function (e.g. a DEFUN) concurrently with
     redefining that same function could lead to execution of random bytes.
   * bug fix: yes-or-no-p accepts formatter functions (lp#1639490)

base-target-features.lisp-expr

@@ -183,6 +183,14 @@
  ;; consider disabling this feature and reporting a bug.
  ; :immobile-space
 
+ ;; Allocate most functions in the immobile space.
+ ;; Enabled by default if supported.
+ ;; The down-side of this feature is that the allocator is significantly
+ ;; slower than the allocator for movable code. If a particular application
+ ;; is performance-constrained by speed of creation of compiled functions
+ ;; (not including closures), the feature can be disabled.
+ ; :immobile-code
+
  ;; Combine the layout pointer, instance-length, and widetag of INSTANCE
  ;; into a single machine word. This represents a space savings of anywhere
  ;; from 4% to 8% in typical applications. (Your mileage may vary).

make-config.sh

@@ -667,7 +667,7 @@ elif [ "$sbcl_arch" = "x86-64" ]; then
     case "$sbcl_os" in
     linux | darwin)
         # probably works on *BSD but not tested
-        printf ' :immobile-space :compact-instance-header' >> $ltf
+        printf ' :immobile-space :immobile-code :compact-instance-header' >> $ltf
     esac
 elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :cheneygc :linkage-table' >> $ltf

src/assembly/assemfile.lisp

@@ -39,6 +39,7 @@
          (*elsewhere* nil)
          (*assembly-optimize* nil)
          (*fixup-notes* nil)
+         #!+immobile-code (*code-is-immobile* t)
          #!+inline-constants (*unboxed-constants* nil))
     (unwind-protect
         (let ((*features* (cons :sb-assembling *features*)))

src/assembly/x86-64/arith.lisp

@@ -32,6 +32,8 @@
 
 #+sb-xc-host
 (defmacro static-fun-addr (name)
+  #!+immobile-code `(make-fixup ,name :static-call)
+  #!-immobile-code
   `(make-ea :qword :disp (+ nil-value (static-fun-offset ,name))))
 
 ;;;; addition, subtraction, and multiplication

src/assembly/x86-64/support.lisp

@@ -10,8 +10,13 @@
 (in-package "SB!VM")
 
 (defun invoke-asm-routine (inst routine vop temp-reg)
-  (declare (ignore vop))
-  (inst mov temp-reg (make-fixup routine :assembly-routine))
+  (declare (ignorable vop))
+  (cond #!+immobile-code
+        ((neq (sb!c::component-kind
+               (sb!c::node-component (sb!c::vop-node vop))) :toplevel)
+         (setq temp-reg (make-fixup routine :assembly-routine)))
+        (t
+         (inst mov temp-reg (make-fixup routine :assembly-routine))))
   (ecase inst
    (jmp  (inst jmp temp-reg))
    (call (inst call temp-reg))))

src/code/alloc.lisp

@@ -133,7 +133,7 @@
          (table (cdr freelist))
          (old (gethash (hole-size hole) table)))
     ;; Check for double-free error
-    #+immobile-space-debug (aver (not (member hole (gethash size table))))
+    #!+immobile-space-debug (aver (not (member hole (gethash size table))))
     (unless old
       (setf (car freelist)
             (sorted-list-insert size (car freelist) #'identity)))
@@ -147,7 +147,7 @@
          (old-length (length list))
          (new (delete hole list :count 1)))
     (declare (ignorable old-length))
-    #+immobile-space-debug (aver (= (length new) (1- old-length)))
+    #!+immobile-space-debug (aver (= (length new) (1- old-length)))
     (cond (new
            (setf (gethash key table) new))
           (t
@@ -185,7 +185,7 @@
                  n-fixnum-tag-bits)))))
 
 (defun unallocate (hole)
-  #+immobile-space-debug
+  #!+immobile-space-debug
   (awhen *in-use-bits* (mark-range it hole (hole-size hole) nil))
   (let* ((hole-end (hole-end-address hole))
          (end-is-free-ptr (eql (ash hole-end (- n-fixnum-tag-bits))
@@ -327,7 +327,7 @@
         (when (>= page-start obj-end) (return))
         (setf (deref varyobj-page-scan-start-offset index)
               (ash (- page-end addr) (- (1+ word-shift))))))
-     #+immobile-space-debug ; "address sanitizer"
+     #!+immobile-space-debug ; "address sanitizer"
      (awhen *in-use-bits* (mark-range it addr n-bytes t))
      (setf (sap-ref-word (int-sap addr) 0) word0
            (sap-ref-word (int-sap addr) n-word-bytes) word1)

src/code/debug-int.lisp

@@ -3280,7 +3280,8 @@ register."
            (trap-loc (static-foreign-symbol-sap "fun_end_breakpoint_trap"))
            (length (sap- src-end src-start))
            (code-object
-             (sb!c:allocate-code-object bogus-lra-constants length))
+             (sb!c:allocate-code-object #!+immobile-code nil
+                                        bogus-lra-constants length))
            (dst-start (code-instructions code-object)))
       (declare (type system-area-pointer
                      src-start src-end dst-start trap-loc)

src/code/fop.lisp

@@ -622,6 +622,14 @@ a bug.~@:>")
                            kind)
   code-object)
 
+#!+immobile-code
+(!define-fop 135 :not-host (fop-static-call-fixup (code-object kind name))
+  (sb!vm:fixup-code-object code-object
+                           (read-word-arg (fasl-input-stream))
+                           (sb!vm::function-raw-address name)
+                           kind)
+  code-object)
+
 (!define-fop 147 :not-host (fop-foreign-fixup (code-object kind))
   (let* ((len (read-byte-arg (fasl-input-stream)))
          (sym (make-string len :element-type 'base-char)))

src/code/target-load.lisp

@@ -149,7 +149,10 @@
                   (sb!c::*policy* sb!c::*policy*))
              (return-from load
                (if faslp
-                   (load-as-fasl stream verbose print)
+                   (prog1 (load-as-fasl stream verbose print)
+                     ;; Try to ameliorate immobile heap fragmentation
+                     ;; in case somehow nontoplevel code is garbage.
+                     #!+immobile-code (gc))
                    (sb!c:with-compiler-error-resignalling
                      (load-as-source stream :verbose verbose
                                             :print print)))))))
@@ -236,8 +239,9 @@
   (declare (simple-vector stack) (type index ptr))
   (let* ((debug-info-index (+ ptr box-num))
          (toplevel-p (svref stack (1+ debug-info-index)))
-         (code (sb!c:allocate-code-object box-num code-length)))
-    (declare (ignore toplevel-p))
+         (code (sb!c:allocate-code-object #!+immobile-code (not toplevel-p)
+                                          box-num code-length)))
+    (declare (ignorable toplevel-p))
     (setf (%code-debug-info code) (svref stack debug-info-index))
     (loop for i of-type index from sb!vm:code-constants-offset
           for j of-type index from ptr below debug-info-index

src/code/x86-64-vm.lisp

@@ -63,11 +63,18 @@
         (:relative
          ;; Fixup is the actual address wanted.
          ;; Replace word with value to add to that loc to get there.
-         (let* ((loc-sap (+ (sap-int sap) offset))
-                (rel-val (- fixup loc-sap (/ n-word-bytes 2))))
-           (declare (type (unsigned-byte 64) loc-sap)
-                    (type (signed-byte 32) rel-val))
-           (setf (signed-sap-ref-32 sap offset) rel-val))))))
+         ;; In the #!-immobile-code case, there's nothing to assert.
+         ;; Relative fixups pretty much can't happen.
+         #!+immobile-code
+         (unless (<= immobile-space-start (get-lisp-obj-address code) immobile-space-end)
+           (error "Can't compute fixup relative to movable object ~S" code))
+         (setf (signed-sap-ref-32 sap offset)
+               (etypecase fixup
+                 (integer
+                  ;; JMP/CALL are relative to the next instruction,
+                  ;; so add 4 bytes for the size of the displacement itself.
+                  (- fixup
+                     (the (unsigned-byte 64) (+ (sap-int sap) offset 4))))))))))
     nil)
 
 ;;;; low-level signal context access functions

src/cold/shared.lisp

@@ -219,6 +219,8 @@
           ":IMMOBILE-SPACE is supported only on x86-64")
         ("(and compact-instance-header (not immobile-space))"
           ":COMPACT-INSTANCE-HEADER requires :IMMOBILE-SPACE feature")
+        ("(and immobile-code (not immobile-space))"
+          ":IMMOBILE-CODE requires :IMMOBILE-SPACE feature")
          ;; There is still hope to make multithreading on DragonFly x86-64
          ("(and sb-thread x86 dragonfly)"
           ":SB-THREAD not supported on selected architecture")))

src/compiler/dump.lisp

@@ -1045,6 +1045,10 @@
         (:code-object
          (aver (null name))
          (dump-fop 'fop-code-object-fixup fasl-output))
+        #!+immobile-code
+        (:static-call
+         (dump-non-immediate-object name fasl-output)
+         (dump-fop 'fop-static-call-fixup fasl-output))
         (:symbol-tls-index
          (aver (symbolp name))
          (dump-non-immediate-object name fasl-output)

src/compiler/early-c.lisp

@@ -92,6 +92,9 @@
 
 ;;; miscellaneous forward declarations
 (defvar *code-segment*)
+;; FIXME: this is a kludge due to the absence of a 'vop' argument
+;; to ALLOCATION-TRAMP in the x86-64 backend.
+(defvar *code-is-immobile*)
 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
 (defvar *component-being-compiled*)
 (defvar *compiler-error-context*)

src/compiler/generic/core.lisp

@@ -72,6 +72,9 @@
                     (:code-object
                      (aver (null name))
                      (get-lisp-obj-address code))
+                    #!+immobile-code
+                    (:static-call
+                     (sb!vm::function-raw-address name))
                     (:symbol-tls-index
                      (aver (symbolp name))
                      (ensure-symbol-tls-index name)))))
@@ -111,3 +114,24 @@
       (setf (debug-info-source info) source)))
   (setf (core-object-debug-info object) nil)
   (values))
+
+#!+(and immobile-code (host-feature sb-xc))
+(progn
+(defvar *linker-fixups*)
+(defun sb!vm::function-raw-address (name &optional (fun (awhen (find-fdefn name)
+                                                          (fdefn-fun it))))
+  (let ((addr (and fun (get-lisp-obj-address fun))))
+    (cond (addr
+           (cond ((not (<= sb!vm:immobile-space-start addr sb!vm:immobile-space-end))
+                  (error "Can't statically link to ~S: code is movable" name))
+                 ((neq (fun-subtype fun) sb!vm:simple-fun-header-widetag)
+                  (error "Can't statically link to ~S: non-simple function" name))
+                 (t
+                  (sap-ref-word (int-sap addr)
+                                (- (ash sb!vm:simple-fun-self-slot sb!vm:word-shift)
+                                   sb!vm:fun-pointer-lowtag)))))
+          ((boundp '*linker-fixups*)
+           (warn "Deferring linkage to ~S" name)
+           (cons :defer name))
+          (t
+           (error "Can't statically link to undefined function ~S" name))))))

src/compiler/generic/genesis.lisp

@@ -1912,6 +1912,12 @@ core and return a descriptor to it."
 (defun cold-functionp (descriptor)
   (eql (descriptor-lowtag descriptor) sb!vm:fun-pointer-lowtag))
 
+(defun cold-fun-entry-addr (fun)
+  (aver (= (descriptor-lowtag fun) sb!vm:fun-pointer-lowtag))
+  (+ (descriptor-bits fun)
+     (- sb!vm:fun-pointer-lowtag)
+     (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)))
+
 ;;; Handle a DEFUN in cold-load.
 (defun cold-fset (name defn source-loc &optional inline-expansion)
   ;; SOURCE-LOC can be ignored, because functions intrinsically store
@@ -2102,6 +2108,7 @@ core and return a descriptor to it."
 (defvar *cold-assembler-routines*)
 
 (defvar *cold-assembler-fixups*)
+(defvar *cold-static-call-fixups*)
 
 (defun record-cold-assembler-routine (name address)
   (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
@@ -2417,7 +2424,15 @@ core and return a descriptor to it."
     (let* ((routine (car fixup))
            (value (lookup-assembler-reference routine)))
       (when value
-        (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+        (do-cold-fixup (second fixup) (third fixup) value (fourth fixup)))))
+  ;; Static calls are very similar to assembler routine calls,
+  ;; so take care of those too.
+  (dolist (fixup *cold-static-call-fixups*)
+    (destructuring-bind (name kind code offset) fixup
+      (do-cold-fixup code offset
+                     (cold-fun-entry-addr
+                      (cold-fdefn-fun (cold-fdefinition-object name)))
+                     kind))))
 
 #!+sb-dynamic-core
 (progn
@@ -2911,12 +2926,16 @@ core and return a descriptor to it."
              (round-up raw-header-n-words 2))
             (toplevel-p (pop-stack))
             (debug-info (pop-stack))
-            (des (allocate-cold-descriptor *dynamic*
-                                           (+ (ash header-n-words
-                                                   sb!vm:word-shift)
-                                              code-size)
-                                           sb!vm:other-pointer-lowtag)))
-       (declare (ignore toplevel-p))
+            (des (allocate-cold-descriptor
+                  #!-immobile-code *dynamic*
+                  ;; toplevel-p is an indicator of whether the code will
+                  ;; will become garbage. If so, put it in dynamic space,
+                  ;; otherwise immobile space.
+                  #!+immobile-code
+                  (if toplevel-p *dynamic* *immobile-varyobj*)
+                  (+ (ash header-n-words sb!vm:word-shift) code-size)
+                  sb!vm:other-pointer-lowtag)))
+       (declare (ignorable toplevel-p))
        (write-header-word des header-n-words sb!vm:code-header-widetag)
        (write-wordindexed des
                           sb!vm:code-code-size-slot
@@ -3193,6 +3212,16 @@ core and return a descriptor to it."
          (value (descriptor-bits code-object)))
     (do-cold-fixup code-object offset value kind)
     code-object))
+
+#!+immobile-code
+(define-cold-fop (fop-static-call-fixup)
+  (let ((name (pop-stack))
+        (kind (pop-stack))
+        (code-object (pop-stack))
+        (offset (read-word-arg (fasl-input-stream))))
+    (push (list name kind code-object offset) *cold-static-call-fixups*)
+    code-object))
+
 
 ;;;; sanity checking space layouts
 
@@ -3913,6 +3942,7 @@ initially undefined function references:~2%")
            (*unbound-marker* (make-other-immediate-descriptor
                               0
                               sb!vm:unbound-marker-widetag))
+           *cold-static-call-fixups*
            *cold-assembler-fixups*
            *cold-assembler-routines*
            (*deferred-known-fun-refs* nil)

src/compiler/generic/target-core.lisp

@@ -16,13 +16,17 @@
 
 (in-package "SB!C")
 
-(declaim (ftype (sfunction (fixnum fixnum) code-component) allocate-code-object))
-(defun allocate-code-object (boxed unboxed)
+(declaim (ftype (sfunction (#!+immobile-code boolean fixnum fixnum)
+                           code-component) allocate-code-object))
+(defun allocate-code-object (#!+immobile-code immobile-p boxed unboxed)
   #!+gencgc
   (without-gcing
-    (%make-lisp-obj
-     (alien-funcall (extern-alien "alloc_code_object" (function unsigned unsigned unsigned))
-                    boxed unboxed)))
+   (if (or #!+immobile-code immobile-p)
+       #!+immobile-code (sb!vm::allocate-immobile-code boxed unboxed)
+       #!-immobile-code nil
+       (%make-lisp-obj
+        (alien-funcall (extern-alien "alloc_code_object" (function unsigned unsigned unsigned))
+                       boxed unboxed))))
   #!-gencgc
   (%primitive allocate-code-object boxed unboxed))
 
@@ -58,7 +62,8 @@
       (let* ((2comp (component-info component))
              (constants (ir2-component-constants 2comp))
              (box-num (- (length constants) sb!vm:code-constants-offset))
-             (code-obj (allocate-code-object box-num length))
+             ;; All compilation into memory favors the immobile space.
+             (code-obj (allocate-code-object #!+immobile-code t box-num length))
              (fill-ptr (code-instructions code-obj)))
         (declare (type index box-num length))
 

src/compiler/main.lisp

@@ -634,7 +634,10 @@ necessary, since type inference may take arbitrarily long to converge.")
           (maybe-mumble "code ")
 
           (multiple-value-bind (code-length fixup-notes)
-              (generate-code component)
+              (let (#!+immobile-code
+                    (*code-is-immobile*
+                     (neq (component-kind component) :toplevel)))
+                (generate-code component))
 
             #-sb-xc-host
             (when *compiler-trace-output*

src/compiler/target-disassem.lisp

@@ -1841,8 +1841,9 @@
           (invert-address-hash *static-foreign-symbols*
                                *assembler-routines-by-addr*))
     (loop for name in sb!vm:*static-funs*
-          for address = (+ sb!vm::nil-value
-                           (sb!vm::static-fun-offset name))
+          for address =
+          #!+immobile-code (sb!vm::function-raw-address name)
+          #!-immobile-code (+ sb!vm::nil-value (sb!vm::static-fun-offset name))
           do (setf (gethash address *assembler-routines-by-addr*) name))
     ;; Not really a routine, but it uses the similar logic for annotations
     #!+sb-safepoint

src/compiler/x86-64/insts.lisp

@@ -1567,8 +1567,8 @@
                                               (reg-tn-encoding dst))
                           (emit-sized-immediate segment size src))))
                   ((and (fixup-p src)
-                        (or (eq (fixup-flavor src) :foreign)
-                            (eq (fixup-flavor src) :assembly-routine)))
+                        (member (fixup-flavor src)
+                                '(:static-call :foreign :assembly-routine)))
                    (maybe-emit-rex-prefix segment :dword nil nil dst)
                    (emit-byte-with-reg segment #b10111 (reg-tn-encoding dst))
                    (emit-absolute-fixup segment src))