master: Change HW to SW card marking on immobile layout pages

snuglas via Sbcl-commits <[email protected]>
Newsgroups gmane.lisp.steel-bank.cvs
Message-ID <[email protected]>
The branch "master" has been updated in SBCL:
       via  271dd00e2daf8199e31cd9622d3a42553743b7ea (commit)
      from  9814767a46d44439a8341918bde751b9974259ac (commit)

- Log -----------------------------------------------------------------
commit 271dd00e2daf8199e31cd9622d3a42553743b7ea
Author: Douglas Katzman <[email protected]>
Date:   Mon Apr 6 17:37:33 2026 -0400

    Change HW to SW card marking on immobile layout pages
---
 src/code/defstruct.lisp          |  2 ++
 src/code/early-classoid.lisp     |  6 +++++
 src/code/target-defstruct.lisp   | 29 ++++++++++++++++++++-
 src/runtime/immobile-space.c     | 56 +++++++++++++++++++++++++++++++++-------
 tests/immobile-space.impure.lisp |  9 ++++++-
 5 files changed, 91 insertions(+), 11 deletions(-)

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 5d3d90fb9..a7bfc4c26 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -215,6 +215,8 @@
           (values (raw-slot-data-reader-name it) (raw-slot-data-writer-name it)))
          ((eq (dd-type dd) 'funcallable-structure)
           (values '%funcallable-instance-info '%set-funcallable-instance-info))
+         ((eq (dd-name dd) 'layout)
+          (values '%instance-ref '%layout-slot-set))
          (t
           (values '%instance-ref '%instance-set))))
 
diff --git a/src/code/early-classoid.lisp b/src/code/early-classoid.lisp
index 23ba299ec..55697c654 100644
--- a/src/code/early-classoid.lisp
+++ b/src/code/early-classoid.lisp
@@ -199,6 +199,9 @@
 
 ;;; 32-bit is not done yet. Three slots are still used, instead of two.
 
+;;; TODO: this should probably become a BUILTIN-CLASSOID for the same reason
+;;; PATHNAME is (see rev 816d286a), namely to prevent use of COPY-STRUCTURE,
+;;; MAKE-INSTANCE, and (SETF SLOT-VALUE).
 (sb-xc:defstruct (layout (:copier nil)
                          ;; Parsing DEFSTRUCT uses a temporary layout
                          (:constructor make-temporary-layout
@@ -277,6 +280,9 @@
   ;; access to slot-definitions and locations by name, etc.
   ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
   (slot-table #(1 nil) :type simple-vector)
+  ;; In lieu of card-marking, this should maintain a so-called intrusive
+  ;; linked list of layouts touched since last GC
+  ; (chain 0 :type sb-vm:word) ; not yet
   (id-word0 0 :type word)
   (id-word1 0 :type word)
   (id-word2 0 :type word)
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 9ef16e3b6..c72f568d5 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -13,6 +13,32 @@
 
 ;;;; structure frobbing primitives
 
+(export '(%layout-slot-set %layout-slot-cas))
+(defun %layout-slot-set (layout index value)
+  #-immobile-space (%instance-set layout index value)
+  #+immobile-space
+  (sb-vm::with-pseudo-atomic-foreign-calls
+    ;; This is pseudo-atomic because if you mark first and then GC occurs before storing,
+    ;; then GC could (possibly) clear the mark, then you store, and now there's a violation
+    ;; of the marking invariant. If you mark after the store, then you run the risk of an
+    ;; abusive TERMINATE-THREAD causing a violation by aborting before setting the mark.
+    ;; Btw, 1 foreign call per slot assignment is really not a big deal. If you're altering
+    ;; layouts at runtime, slot setting is the least of your problems. Making the hundreds
+    ;; of CLOS metaobjects that go along with class lattice changes is worse by far.
+    (alien-funcall (extern-alien "layout_slot_set" (function void unsigned unsigned int))
+                   (get-lisp-obj-address layout) (get-lisp-obj-address value)
+                   (truly-the (mod 32) index)))
+  value)
+(defun %layout-slot-cas (layout index oldval newval)
+  #-immobile-space (%instance-cas layout index oldval newval)
+  #+immobile-space
+  (sb-vm::with-pseudo-atomic-foreign-calls
+    (%make-lisp-obj
+     (alien-funcall (extern-alien "layout_slot_cas"
+                                  (function unsigned unsigned unsigned unsigned int))
+                    (get-lisp-obj-address layout) (get-lisp-obj-address oldval)
+                    (get-lisp-obj-address newval) (truly-the (mod 32) index)))))
+
 ;;; For lack of any better to place to write up some detail surrounding
 ;;; layout creation for structure types, I'm putting here.
 ;;; When you issue a DEFSTRUCT at the REPL, there are *three* instances
@@ -667,7 +693,8 @@
                     ;; or else a compiled perfect-hash-based mapper. Either way, punt.
                     (funcall old symbol)
                     (let* ((new (make-second-stage-slot-mapper vector))
-                           (actual-old (cas (layout-slot-mapper layout) me new)))
+                           (actual-old
+                            (%layout-slot-cas layout (get-dsd-index layout slot-mapper) me new)))
                       (when (eq actual-old me)
                         (install-hash-based-slot-mapper
                          layout pairs unique-hashes `(slot-mapper ,(dd-name dd))))
diff --git a/src/runtime/immobile-space.c b/src/runtime/immobile-space.c
index e2c5cb7f4..89038c6b5 100644
--- a/src/runtime/immobile-space.c
+++ b/src/runtime/immobile-space.c
@@ -769,6 +769,10 @@ scavenge_immobile_roots(generation_index_t min_gen, generation_index_t max_gen)
     scavenge_immobile_newspace();
 }
 
+static int should_mprotect(low_page_index_t page) {
+    return fixedobj_pages[page].attr.parts.obj_align == SYMBOL_SIZE
+        && fixedobj_page_wp(page);
+}
 void write_protect_immobile_space()
 {
     immobile_scav_queue_head = 0;
@@ -781,14 +785,14 @@ void write_protect_immobile_space()
     int i, start = -1, end = -1; // inclusive bounds on page indices
     low_page_index_t max_used_fixedobj_page = calc_max_used_fixedobj_page();
     for (i = max_used_fixedobj_page ; i >= 0 ; --i) {
-        if (fixedobj_page_wp(i)) {
+        if (should_mprotect(i)) {
             if (end < 0) end = i;
             start = i;
         }
-        if (end >= 0 && (!fixedobj_page_wp(i) || i == 0)) {
+        if (end >= 0 && (!should_mprotect(i) || i == 0)) {
             os_protect(fixedobj_page_address(start),
                        IMMOBILE_CARD_BYTES * (1 + end - start),
-                       OS_VM_PROT_READ|OS_VM_PROT_EXECUTE);
+                       OS_VM_PROT_READ);
             start = end = -1;
         }
     }
@@ -1274,6 +1278,11 @@ void deport_codeblob_offsets_from_heap()
     lispobj* vector_copy = malloc(nbytes);
     loaded_codeblob_offsets = memcpy(vector_copy, loaded_codeblob_offsets, nbytes);
     SYMBOL(IMMOBILE_CODEBLOB_VECTOR)->value = NIL;
+    int page = 0, limit = calc_max_used_fixedobj_page();
+    for (page = 0; page <= limit; ++page) {
+        if (fixedobj_pages[page].attr.parts.obj_align > SYMBOL_SIZE) // layout page
+            SET_WP_FLAG(page, WRITE_PROTECT_CLEARED);
+    }
 }
 
 // Change all objects to generation 0
@@ -1394,18 +1403,32 @@ void prepare_immobile_space_for_save(bool verbose)
 
 int immobile_space_handle_wp_violation(void* fault_addr)
 {
-    low_page_index_t fixedobj_page_index = find_fixedobj_page_index(fault_addr);
-    if (fixedobj_page_index < 0)
+    low_page_index_t page = find_fixedobj_page_index(fault_addr);
+    if (page < 0)
       return 0; // unhandled
 
+#if 0
+    if (fixedobj_pages[page].attr.parts.obj_align == SYMBOL_SIZE) { // good
+        // Should only experience sigsegv on symbols and not layouts
+        int byte_offset = (char*)fault_addr - (char*)PTR_ALIGN_DOWN(fault_addr, IMMOBILE_CARD_BYTES);
+        int object_offset = byte_offset / 48;
+        struct symbol*s = (void*)((object_offset * 48) +
+                                  (char*)PTR_ALIGN_DOWN(fault_addr, IMMOBILE_CARD_BYTES));
+        fprintf(stderr, "fault @ %p page %d object %p\n",
+                fault_addr, page, s /*, (char*)VECTOR(s->name)->data*/);
+    } else {
+        /* Needed for tracking down logic errors in software marking.
+         * To reach here you of course must use mprotect */
+        lose("Unexpected fault on fixedobj page @ %p. Dropping to ldb", fault_addr);
+    }
+#endif
     os_protect(PTR_ALIGN_DOWN(fault_addr, IMMOBILE_CARD_BYTES),
-               IMMOBILE_CARD_BYTES, OS_VM_PROT_ALL);
+               IMMOBILE_CARD_BYTES, OS_VM_PROT_READ|OS_VM_PROT_WRITE);
 
     // FIXME: the _CLEARED flag doesn't achieve much if anything.
-    if (!(fixedobj_pages[fixedobj_page_index].attr.parts.flags
-          & (WRITE_PROTECT|WRITE_PROTECT_CLEARED)))
+    if (!(fixedobj_pages[page].attr.parts.flags & (WRITE_PROTECT|WRITE_PROTECT_CLEARED)))
         return 0;
-    SET_WP_FLAG(fixedobj_page_index, WRITE_PROTECT_CLEARED);
+    SET_WP_FLAG(page, WRITE_PROTECT_CLEARED);
 
     return 1;
 }
@@ -2167,3 +2190,18 @@ void* expropriate_memory_from_tlsf(size_t amount)
 #endif
   return start;
 }
+
+void layout_slot_set(lispobj layout, lispobj newval, int slot)
+{
+    struct instance *i = INSTANCE(layout);
+    low_page_index_t page = find_fixedobj_page_index(i);
+    SET_WP_FLAG(page, WRITE_PROTECT_CLEARED);
+    i->slots[slot] = newval;
+}
+lispobj layout_slot_cas(lispobj layout, lispobj old, lispobj new, int slot)
+{
+    struct instance *i = INSTANCE(layout);
+    low_page_index_t page = find_fixedobj_page_index(i);
+    SET_WP_FLAG(page, WRITE_PROTECT_CLEARED);
+    return __sync_val_compare_and_swap(&i->slots[slot], old, new);
+}
diff --git a/tests/immobile-space.impure.lisp b/tests/immobile-space.impure.lisp
index 052ccb91c..416540dec 100644
--- a/tests/immobile-space.impure.lisp
+++ b/tests/immobile-space.impure.lisp
@@ -12,7 +12,14 @@
 ;;; the second one was more likely to crash
 (dotimes (i 1000 (gc)) (alloc-layoutless-instances))
 
-(defstruct trythis a)
+;;; This test creates a TRYTHIS instance on a page of layouts. It is no longer legal
+;;; to set slots of instances of layout pages without going through the GC store barrier.
+;;; Therefore define a setter that calls %LAYOUT-SLOT-SET.
+;;; And honestly I don't know what this test is actually testing.
+(defstruct trythis (%a nil :read-only t))
+(defun trythis-a (instance) (trythis-%a instance))
+(defun (setf trythis-a) (newval instance)
+  (sb-kernel:%layout-slot-set (the trythis instance) 0 newval))
 
 ;;; Assign a bitmap that is not the special case for "all tagged"
 ;;; but does correctly indicate 1 tagged slot.

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.