common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix arena-related crash

Browse source
This commit is contained in:
Douglas Katzman 2026-07-16 15:46:05 +00:00
parent e3c2db021f
commit 8796281182
2 changed files with 27 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
src/code/target-defstruct.lisp
View file

@ -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))))

20
tests/arena.impure.lisp
View file

@ -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))))))