From 8796281182447fa2091610881629204729b04793 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 16 Jul 2026 15:46:05 +0000 Subject: [PATCH] Fix arena-related crash --- src/code/target-defstruct.lisp | 11 +++++++---- tests/arena.impure.lisp | 20 ++++++++++++++++++++ 2 files changed, 27 insertions(+), 4 deletions(-) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 6130d606c..93540faf3 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -614,6 +614,7 @@ (h (progn ,@body))) (if (< h ,nbuckets) ,resultform))))))) +;;; Unclear why this is in SB-PCL package. It's used more from here. (declaim (inline sb-pcl::search-struct-slot-name-vector)) (defun sb-pcl::search-struct-slot-name-vector (mapper slot-name) (declare (optimize (sb-c::insert-array-bounds-checks 0))) @@ -665,6 +666,7 @@ ;;; until the function is called (which may never occur), and secondly the caller ;;; is never delayed by waiting for the compiler. (defun install-struct-slot-mapper (layout) + (declare (sb-c::tlab :system)) (let* ((dd (layout-dd layout)) (slots (dd-slots dd)) (keys (map 'vector #'dsd-name slots)) @@ -683,6 +685,7 @@ (return-from install-struct-slot-mapper (setf (layout-slot-mapper layout) vector))) (let ((me (%make-slot-mapper-fn)) + (name `(slot-mapper ,(dd-name dd))) (pairs (map 'list #'cons keys values))) (setf (sb-kernel:%funcallable-instance-fun me) (lambda (symbol) @@ -692,13 +695,13 @@ (let ((old (layout-slot-mapper layout))) (if (neq old me) ; if it's not ME, then it's either the second stage mapper ;; or else a compiled perfect-hash-based mapper. Either way, punt. - (funcall old symbol) - (let* ((new (make-second-stage-slot-mapper vector)) + (funcall (the function old) symbol) + (let* ((new (lambda (symbol) + (sb-pcl::search-struct-slot-name-vector vector symbol))) (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)))) + (install-hash-based-slot-mapper layout pairs unique-hashes name)) (funcall new symbol)))))) (setf (layout-slot-mapper layout) me)))) diff --git a/tests/arena.impure.lisp b/tests/arena.impure.lisp index b88097da9..6b87ea20b 100644 --- a/tests/arena.impure.lisp +++ b/tests/arena.impure.lisp @@ -727,3 +727,23 @@ (sb-thread:join-thread thread) (assert (heap-allocated-p (sb-thread:thread-name thread)))) (destroy-arena arena)))) + +(defstruct fleemazoid a b c d e f g) +(defun get-a-slot (inst sym) (slot-value (the fleemazoid inst) sym)) +;; Just in case we decide that this file can run in --evaluator-mode interpret +;; (which it currently can't) ensure that slot-value uses the layout slot mapper. +(compile 'get-a-slot) +(test-util:with-test (:name :slot-mapper-not-in-arena) + (let ((a (sb-vm:new-arena 65536))) + (sb-vm:with-arena (a) + (get-a-slot (make-fleemazoid :c "hi-c") 'c)) + (destroy-arena a) + ;; There's no way to know when the background compile is done, we can't really + ;; do any better than to wait a little. Deciding based on whether the finalizer's + ;; work queue is empty constitutes a data race- it grabs an item and then compiles, + ;; so you don't know when COMPILE is actually done. + (sleep .1) + (let ((fun (sb-kernel::layout-slot-mapper (sb-kernel:find-layout 'fleemazoid)))) + (assert (sb-kernel:simple-fun-p fun)) + (let ((name (sb-kernel:%simple-fun-name fun))) + (assert (sb-ext:heap-allocated-p name))))))