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

Add GC support for lockfree singly-linked lists

Browse source 
Based on paper by Tim Harris @ https://timharris.uk/papers/2001-disc.pdf.
The algorithm depends on arbitrarily manipulation of 1 bit of a pointer
which we can do by relaxing the tagging requirement for pointers from a
node to its successor. For technical reasons, our representation differs
from that in the reference paper - for us, the lowtag bits of a successor
pointer are either all correct (INSTANCE_POINTER_LOWTAG), or all 0.

The code has been lightly exercised on arm64, ppc, x86, and x86-64.
I'm still deciding on the interface that we want to expose,
and where such lists can be used internally.
This commit is contained in:
Douglas Katzman 2018-11-18 20:55:14 -05:00
parent ac1192682c
commit 75828dee01
15 changed files with 551 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
build-order.lisp-expr
View file

@ -704,6 +704,7 @@
;; It could be done in genesis, but not earlier,
;; since the host has a package of that name.
"src/code/defpackage"
"src/code/target-lflist"
"src/pcl/walk") ; needs DEFPACKAGE
#+sb-fasteval

2
cross-make.sh
View file

@ -30,7 +30,7 @@ case $1 in
checkout="echo not syncing remote"
;;
*)
echo "Usage error: cross-make.sh {sync|head|nosync} host port [env]"
echo "Usage error: cross-make.sh {sync|head|nosync} host dir [env]"
exit 1
esac
shift

4
src/code/save.lisp
View file

@ -465,5 +465,7 @@ sb-c::
((neq name new)
(setf (%instance-ref debug-fun
(get-dsd-index compiled-debug-fun name))
new)))))))))))
new)))))))
(sb-lfl::linked-list
(sb-lfl::finalize-deletion obj))))))
:all))))

289
src/code/target-lflist.lisp Normal file
View file

@ -0,0 +1,289 @@
;;;; Lockfree singly-linked lists
;;;; using the algorithm of https://timharris.uk/papers/2001-disc.pdf.
;;;; The algorithm as described requires being able to change the
;;;; low-order bit of a pointer from 0 to 1 to mark pending deletions.
;;;; Java implementations support this through a wrapper object
;;;; known as AtomicMarkableReference.
;;;; SBCL directly supports the mark bit by using the lowtag.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(defpackage "SB-LFL"
(:use "CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL"))
(in-package "SB-LFL")
;;; The changes to GC to support this code were as follows:
;;; * One bit of the payload length in an instance header is reserved to signify
;;; that the instance has a special GC scavenge method. This avoids indirecting
;;; to the layout to see whether all instances of a type have a special method.
;;;
;;; * If an instance has a header bit so indicating, then the first data slot
;;; is treated as an instance pointer even if it missing its tag bits.
;;;
;;; * Since you can't pin an object that you don't a-priori have a tagged pointer
;;; to, pinning a lockfree list node may implicitly pin not only that node but
;;; also the successor node, since there would otherwise be no way to reconstruct
;;; (in Lisp) a tagged pointer to the successor of a node pending deletion.
;;;
;;; * Copying a lockfree list node tries to copy the successor nodes into adjacent
;;; memory just like copying a chain of cons cells. This is inessential but nice.
;;;
;;; * verify_range() knows how to verify the 'next' pointer even when it looks like
;;; a fixnum. Without this it would have been more difficult to test the above.
;;;
;;; The remaining issue is relatively unimportant: neither traceroot nor
;;; DO-REFERENCED-OBJECT can follow untagged pointers.
;;; This is potentially more of an annoyance than it is a bug.
(defstruct (node (:conc-name nil)
(:constructor %make-node (node-key node-data)))
;; Using either 0 or NIL as the 'next' would make sense for the final cell.
;; 0 makes things easier for C, but NIL makes things easier for Lisp.
;; Using NIL simplifies the test in MARKEDP+NEXT so that the condition
;; for ORing in tag bits is simply whether 'next' is a fixnum.
;; Using 0 would require checking for fixnum and non-zero.
(%node-next nil)
(node-data)
(node-key 0 :read-only t))
;;; Change the layout bitmap from -1 to a bitmap with 1s for each tagged slot.
;;; These are essentially equivalent, however -1 indicates that all slots are
;;; tagged *and* that there is no special scavenge method.
;;; A positive number _may_ indicate that all slots are tagged, but also
;;; informs the scavenge that there may be a custom action as well.
(let ((layout (sb-kernel:find-layout 'node)))
(setf (layout-bitmap layout)
;; Round to odd, make any padding slot tagged.
;; If we allow subtypes of NODE, then the bitmap will have to
;; be fixed up as well.
(1- (ash 1 (logior (layout-length layout) 1)))))
(defconstant special-gc-strategy-flag #x800000)
(declaim (ftype (sfunction (t t) node) make-node))
(defun make-node (key data)
(declare (inline %make-node))
(let ((n (%make-node key data)))
;; FIXME: this bit needs to be frobbed with a vop, or better yet,
;; just set in the allocator; and should (ideally) be made atomic.
;; Note that SET-HEADER-DATA only works on OTHER-POINTER-LOWTAG.
(with-pinned-objects (n)
(let ((sap (int-sap (get-lisp-obj-address n))))
(setf (sap-ref-word sap (- sb-vm:instance-pointer-lowtag))
(logior special-gc-strategy-flag
(sap-ref-word sap (- sb-vm:instance-pointer-lowtag))))))
n))
(define-load-time-global *tail-atom* (make-node nil :tail))
;;; Specialized list variants will be created for
;;; fixnum, integer, real, string, generic "comparable"
;;; but the node type and list type is the same regardless of key type.
(defstruct (linked-list (:constructor %make-lfl)
(:conc-name list-))
(head nil :type node)
(tail nil :type node))
(defun new-lockfree-list ()
(let ((head (make-node nil :head))
(tail *tail-atom*))
(setf (%node-next head) tail)
(%make-lfl :head head :tail tail)))
;;; "Marked" in the reference algorithm means ORing in a 1 to the low bit.
;;; For us it means *removal* of tag bits.
;;; MAKE-MARKED-REF can only be called in the scope of WITH-PINNED-OBJECTS.
;;; The critical invariant is that once a 'next' pointer has been turned into
;;; a fixnum, it CAN NOT change. Therefore, the object that GC implicitly pins
;;; - along with the explicit pin of NODE within MARKED+NEXT - is definitely the
;;; object whose tagged pointer is reconstructed. This is exactly why we choose
;;; the tagged state as the normal state and the untagged state as deleted.
;;; If that were reversed (so tag bits = deleted, no tag bits = normal) to be like
;;; the reference algorithm, wherein "marked" = "deleted", object pinning
;;; could fail. A competing thread could CAS the untagged bits, invoke GC, while we
;;; try to reconstructed a different object from bits that were read prior to the CAS
;;; and prior to the GC, during which time the object to reconstruct moved.
(declaim (inline make-marked-ref))
(defun make-marked-ref (x)
(%make-lisp-obj (logandc2 (get-lisp-obj-address x) sb-vm:lowtag-mask)))
(declaim (inline markedp markedp+next))
(defun markedp (node) (fixnump (%node-next node)))
(defun markedp+next (node)
(with-pinned-objects (node) ; pinning a node also pins its 'next'
(let ((next (%node-next node)))
(if (fixnump next)
(values t (truly-the node
(%make-lisp-obj (logior (get-lisp-obj-address next)
sb-vm:instance-pointer-lowtag))))
(values nil (truly-the node next))))))
(defun node-next (node)
(nth-value 1 (markedp+next node)))
(defmethod print-object ((list linked-list) stream)
(print-unreadable-object (list stream :type t)
(write-char #\{ stream)
(let ((node (%node-next (list-head list))))
(unless (eq node (list-tail list))
(loop (multiple-value-bind (deleted next) (markedp+next node)
(when deleted
(write-char #\* stream))
(write (node-key node) :stream stream)
(setq node next)
(when (eq node (list-tail list)) (return))
(write-char #\space stream)))))
(write-char #\} stream)))
(defmethod print-object ((node node) stream)
(print-unreadable-object (node stream :type t)
(format stream "(~:[~;*~]~D ~S)"
(markedp node)
(node-key node)
(node-data node))))
(defmacro do-lockfree-list ((var list &optional result) &body body)
`(let* ((.list. ,list)
(.end. (list-tail .list.))
(,var (%node-next (list-head .list.))))
(loop
(when (eq ,var .end.) (return ,result))
(multiple-value-bind (.mark. .next.) (markedp+next (truly-the node ,var))
(unless .mark. (let ((,var ,var)) (declare (ignorable ,var)) ,@body))
(setq ,var .next.)))))
(defun lfl-length (list) ; a snapshot at a point in time
(let ((n 0))
(do-lockfree-list (x list) (incf n))
n))
;;; SEARCH returns a pair of nodes satisfying the following constraints:
;;; - key(left) < search-key and key(right) >= search-key
;;; - neither left nor right is marked for deletion
;;; - right is the immediate successor of left
;;; Any logically deleted nodes in between left and right will be removed.
(defmacro lfl-search-macro (compare< type)
`(block search
(let (left left-node-next right (tail (list-tail list)))
(tagbody
again
;; 1. Find left and right nodes
(binding* ((this (list-head list))
((markedp next) (markedp+next this)))
(loop (unless markedp
(setq left this left-node-next next))
(when (eq (setq this next) tail)
(return))
(multiple-value-setq (markedp next) (markedp+next this))
(unless (or markedp (,compare< (truly-the ,type (node-key this))
key))
(return)))
(setq right this))
;; 2. Check adjacency
(when (eq left-node-next right)
(if (and (neq right tail) (markedp right))
(go again)
(return-from search (values right left))))
;; 3. Remove intervening marked nodes
(when (eq (cas (%node-next (truly-the node left)) left-node-next right)
left-node-next)
(unless (and (neq right tail) (markedp right))
(return-from search (values right left))))
(go again)))))
;;; This is pretty much the standard CAS-based atomic list insert algorithm.
(defmacro lfl-insert-macro (search compare= type)
`(let ((new (make-node key data)))
(loop
;; LEFT and RIGHT are the nodes bracketing the insertion point.
(multiple-value-bind (right left) (,search list key)
(when (and (neq right (list-tail list))
(,compare= key (truly-the ,type (node-key right))))
(return nil))
(setf (%node-next new) right)
(when (eq (cas (%node-next left) right new) right)
(return new))))))
;;; Deletion
;;; Step 1: find the node to be deleted
;;; Step 2: mark it as pending deletion in the 'next' slot
;;; Step 3: swing the predecessor's next to the successor of deleted node.
;;;
;;; Example: After step 2 of deleting node C we have:
;;; A --> B --> C --> D
;;; ^ (mark)
;;; If swapping node B's 'next' fails, then some operation occurred to the left.
;;; Due to deletion the predecessor of C might become node A:
;;; A --> C --> D
;;; Due to insertion the predecessor of C might become node X:
;;; A --> B --> X --> C --> D
(defmacro lfl-delete-macro (search compare= type)
`(loop
;; Step 1: find
(multiple-value-bind (this predecessor) (,search list key)
(when (or (eql this (list-tail list))
(not (,compare= key (truly-the ,type (node-key this)))))
(return nil))
(let ((succ (%node-next this)))
(unless (fixnump succ)
;; Pin here because we're taking the address of the successor object.
;; Instead we could use bit-test-and-set on the x86 architecture.
(with-pinned-objects (succ)
;; Step 2: logically delete 'this'
(when (eq (cas (%node-next this) succ (make-marked-ref succ)) succ)
;; Step 3: physically delete by swinging the predecessor's successor
(unless (eq succ (cas (%node-next predecessor) this succ))
;; Call SEARCH again which will perform physical deletion.
(,search list key))
(return t))))))))
(defmacro define-variation (type compare< compare=)
(let ((search (symbolicate "LFL-SEARCH/" type)))
`(progn
(declaim (ftype (sfunction (linked-list ,type) (values node node))
,search))
(defun ,search (list key) (lfl-search-macro ,compare< ,type))
(defun ,(symbolicate "LFL-INSERT/"type) (list key data)
(declare (linked-list list) (,type key))
(lfl-insert-macro ,search ,compare= ,type))
(defun ,(symbolicate "LFL-DELETE/"type) (list key)
(declare (linked-list list) (,type key))
(lfl-delete-macro ,search ,compare= ,type))
(defun ,(symbolicate "LFL-FIND/"type) (list key)
(declare (linked-list list) (,type key))
(let ((node (,search list key)))
(when (and (neq node (list-tail list))
(,compare= key (truly-the ,type (node-key node))))
node))))))
(define-variation real < =) ; uses general case of math functions
;; TODO: implement an INTEGER< assembly routine perhaps?
(define-variation integer < =) ; comparator= reduces to INTEGER-EQL
(define-variation fixnum < =)
(define-variation string string< string=)
;;; SAVE-LISP-AND-DIE must unlink logically deleted nodes, because coreparse
;;; would not understand how to followed untagged pointers in the event that
;;; heap relocation had to occur on restart. Of course the only way to see
;;; a logically deleted node here is if a deleting thread died a horrible
;;; sudden death.
;;; Each list will be processed exactly once.
(defun finalize-deletion (list)
(let* ((pred (list-head list))
(node (node-next pred)))
(loop
(when (eq node (list-tail list))
(return))
(multiple-value-bind (markedp next) (markedp+next node)
(if markedp
(setf node next (%node-next pred) node)
(setf pred node node next))))))

3
src/compiler/arm64/cell.lisp
View file

@ -449,7 +449,8 @@
(:result-types positive-fixnum)
(:generator 4
(loadw temp struct 0 instance-pointer-lowtag)
(inst lsr res temp n-widetag-bits)))
(inst ubfm res temp n-widetag-bits
(+ -1 (integer-length short-header-max-words) n-widetag-bits))))
(define-full-reffer instance-index-ref * instance-slots-offset
instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)

4
src/compiler/ppc/cell.lisp
View file

@ -472,7 +472,9 @@
(:result-types positive-fixnum)
(:generator 4
(loadw temp struct 0 instance-pointer-lowtag)
(inst srwi res temp n-widetag-bits)))
;; shift right 8 and mask 15 low bits =
;; rotate left 24, take bit indices 17 through 31.
(inst rlwinm res temp (- 32 n-widetag-bits) 17 31)))
(define-vop (instance-index-ref word-index-ref)
(:policy :fast-safe)

1
src/compiler/x86-64/cell.lisp
View file

@ -646,6 +646,7 @@
(:result-types positive-fixnum)
(:generator 4
(inst movzx '(:word :dword) res (ea (1+ (- instance-pointer-lowtag)) struct))
(inst and :dword res short-header-max-words) ; clear special GC bit
(inst shl :dword res n-fixnum-tag-bits)))
#!+compact-instance-header

3
src/compiler/x86/cell.lisp
View file

@ -458,7 +458,8 @@
(:result-types positive-fixnum)
(:generator 4
(loadw res struct 0 instance-pointer-lowtag)
(inst shr res n-widetag-bits)))
(inst shr res n-widetag-bits)
(inst and res short-header-max-words))) ; clear special GC bit
(define-full-reffer instance-index-ref *
instance-slots-offset instance-pointer-lowtag

10
src/runtime/fullcgc.c
View file

@ -16,6 +16,7 @@
#include "genesis/gc-tables.h"
#include "genesis/closure.h"
#include "genesis/cons.h"
#include "genesis/instance.h"
#include "genesis/vector.h"
#include "genesis/layout.h"
#include "genesis/hash-table.h"
@ -269,7 +270,16 @@ static void trace_object(lispobj* where)
// mixed boxed/unboxed objects
bitmap = ((struct layout*)native_pointer(layout))->bitmap;
// If no raw slots, just scan without use of the bitmap.
// A bitmap of -1 implies that not only are all slots tagged,
// there is no special GC method for any slot.
if (bitmap == make_fixnum(-1)) break;
// Otherwise, the first slot might merit special treatment.
if (*where & CUSTOM_GC_SCAVENGE_FLAG) {
struct instance* node = (struct instance*)where;
lispobj next = node->slots[INSTANCE_DATA_START];
if (fixnump(next) && next) // ignore initially 0 heap words
__mark_obj(next|INSTANCE_POINTER_LOWTAG);
}
for(i=1; i<scan_to; ++i)
if (layout_bitmap_logbitp(i-1, bitmap) && is_lisp_pointer(where[i]))
__mark_obj(where[i]);

57
src/runtime/gc-common.c
View file

@ -105,7 +105,8 @@ os_vm_size_t bytes_consed_between_gcs = 12*1024*1024;
/* Medium-sized payload count is expressed in 15 bits. Objects in this category
* may reside in immobile space: CLOSURE, INSTANCE, FUNCALLABLE-INSTANCE.
* The single data bit is used as a closure's NAMED flag.
* The single data bit is used as a closure's NAMED flag,
* or an instance's "special GC strategy" flag.
*
* Header: gen# | data | size | tag
* ----- ----- ------- ------
@ -476,19 +477,36 @@ trans_fun_header(lispobj object)
* instances
*/
static inline lispobj copy_instance(lispobj object)
{
// Object is an un-forwarded object in from_space
lispobj header = *(lispobj*)(object - INSTANCE_POINTER_LOWTAG);
lispobj copy = copy_object(object, 1 + (instance_length(header)|1));
set_forwarding_pointer(native_pointer(object), copy);
return copy;
}
static sword_t
scav_instance_pointer(lispobj *where, lispobj object)
{
gc_dcheck(instancep(object));
lispobj header = *(lispobj*)(object - INSTANCE_POINTER_LOWTAG);
/* Object is a pointer into from space - not a FP. */
lispobj copy = copy_object(object, 1 + (instance_length(header)|1));
gc_dcheck(copy != object);
set_forwarding_pointer(native_pointer(object), copy);
lispobj copy = copy_instance(object);
*where = copy;
struct instance* node = (struct instance*)(copy - INSTANCE_POINTER_LOWTAG);
// Copy chain of lockfree list nodes to consecutive memory addresses,
// just like trans_list does. A logically deleted node will break the chain,
// as its 'next' will not satisfy instancep(), but that's ok.
if (node->header & CUSTOM_GC_SCAVENGE_FLAG) {
while (instancep(object = node->slots[INSTANCE_DATA_START]) // node.next
&& from_space_p(object)
&& !forwarding_pointer_p(native_pointer(object))) {
copy = copy_instance(object);
node->slots[INSTANCE_DATA_START] = copy;
node = (struct instance*)(copy - INSTANCE_POINTER_LOWTAG);
}
}
return 1;
}
@ -691,9 +709,28 @@ scav_instance(lispobj *where, lispobj header)
lbitmap = ((struct layout*)layout)->bitmap;
}
sword_t nslots = instance_length(header) | 1;
if (lbitmap == make_fixnum(-1))
if (lbitmap == make_fixnum(-1)) {
scavenge(where+1, nslots);
else if (!fixnump(lbitmap)) {
return 1 + nslots;
}
// Specially scavenge the 'next' slot of a lockfree list node. If the node is
// pending deletion, 'next' will satisfy fixnump() but is in fact a pointer.
// GC doesn't care too much about the deletion algorithm, but does have to
// ensure liveness of the pointee, which may move unless pinned.
// One could imagine that the strategy is further determind by layout->_flags.
// A single bit suffices for now, but more generality is certainly possible.
if (header & CUSTOM_GC_SCAVENGE_FLAG) {
struct instance* node = (struct instance*)where;
lispobj next = node->slots[INSTANCE_DATA_START];
if (fixnump(next) && next) { // ignore initially 0 heap words
lispobj descriptor = next | INSTANCE_POINTER_LOWTAG;
scav1(&descriptor, descriptor);
// Fix the pointer but of course leave it in mid-deletion (untagged) state.
if (descriptor != (next | INSTANCE_POINTER_LOWTAG))
node->slots[INSTANCE_DATA_START] = descriptor & ~LOWTAG_MASK;
}
}
if (!fixnump(lbitmap)) {
/* It is conceivable that 'lbitmap' points to from_space, AND that it
* is stored in one of the slots of the instance about to be scanned.
* If so, then forwarding it will deposit new bits into its first

2
src/runtime/gc-private.h
View file

@ -22,6 +22,8 @@
// Even on cheneygc we need this flag, but it's actually just ignored.
#define ALLOC_QUICK 1
#define CUSTOM_GC_SCAVENGE_FLAG 0x800000
#ifdef LISP_FEATURE_GENCGC
#include "gencgc-alloc-region.h"
void *

27
src/runtime/gencgc.c
View file

@ -1879,6 +1879,23 @@ pin_object(lispobj object)
})
}
}
if (lowtag_of(object) == INSTANCE_POINTER_LOWTAG
&& (*(lispobj*)(object - INSTANCE_POINTER_LOWTAG)
& CUSTOM_GC_SCAVENGE_FLAG)) {
struct instance* instance = (struct instance*)(object - INSTANCE_POINTER_LOWTAG);
// When pinning a logically deleted lockfree list node, always pin the
// successor too, since the Lisp code will reconstruct the next node's tagged
// pointer from the native pointer. Since we're still in the object pinning phase
// of GC, layouts can't have been forwarded yet. In fact we don't use bits
// from the layout, but it's worth noting, in case we needed to.
// Note also that this 'pin' does not need to happen for mark-only GC.
// The pin is from an address perspective, not a liveness perspective,
// because the instance scavenger would correctly trace this reference.
lispobj next = instance->slots[INSTANCE_DATA_START];
// Be sure to ignore 0 words.
if (fixnump(next) && next && from_space_p(next | INSTANCE_POINTER_LOWTAG))
pin_object(next | INSTANCE_POINTER_LOWTAG);
}
}
#else
# define scavenge_pinned_ranges()
@ -2697,6 +2714,16 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
lispobj bitmap = layout->bitmap;
gc_assert(fixnump(bitmap)
|| widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG);
if (*where & CUSTOM_GC_SCAVENGE_FLAG) {
struct instance* node = (struct instance*)where;
lispobj next = node->slots[INSTANCE_DATA_START];
if (fixnump(next) && next) {
state->vaddr = &node->slots[INSTANCE_DATA_START];
next |= INSTANCE_POINTER_LOWTAG;
verify_range(&next, 1, state);
state->vaddr = 0;
}
}
instance_scan((void (*)(lispobj*, sword_t, uword_t))verify_range,
where+1, nslots, bitmap, (uintptr_t)state);
count = 1 + nslots;

2
src/runtime/traceroot.c
View file

@ -152,6 +152,7 @@ static int find_ref(lispobj* source, lispobj target)
bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1);
for(i=1; i<scan_limit; ++i)
if (layout_bitmap_logbitp(i-1, bitmap)) check_ptr(i, source[i]);
// FIXME: check CUSTOM_GC_SCAVENGE in the header
return -1;
#if FUN_SELF_FIXNUM_TAGGED
case CLOSURE_WIDETAG:
@ -718,6 +719,7 @@ static uword_t build_refs(lispobj* where, lispobj* end,
check_ptr(layout);
// Partially initialized instance can't have nonzero words yet
bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1);
// FIXME: check CUSTOM_GC_SCAVENGE in the header
// If no raw slots, just scan without use of the bitmap.
if (bitmap == make_fixnum(-1)) break;
for(i=1; i<scan_limit; ++i)

157
tests/lockfree-list.impure.lisp Normal file
View file

@ -0,0 +1,157 @@
(in-package "SB-LFL")
#-(and sb-thread (or arm64 ppc x86 x86-64)) (sb-ext:exit :code 104)
;;;; These functions are for examining GC behavior.
(defun lfl-nth (n list)
(let ((node (%node-next (list-head list))))
(dotimes (i n node)
(setq node (node-next node)))))
;;; For testing (especially the garbage collector), perform the first CAS
;;; operation but not the second CAS of the deletion algorithm.
(defun logical-delete (n list)
(let* ((node (lfl-nth n list))
(succ (%node-next node)))
(unless (fixnump succ)
(with-pinned-objects (succ)
(cas (%node-next node) succ (make-marked-ref succ)))))
list)
(defvar *lfl*)
(defvar *l*)
(flet ((show (node step when)
(format t "~a: " when)
(loop (format t "~x" (get-lisp-obj-address node))
(unless (setq node (funcall step node)) (return))
(format t " - "))
(terpri)))
(defun makelist (n)
(setq *l* nil)
(dotimes (i n) (push (cons i (format nil "~r" i)) *l*))
(show *l* #'cdr "init")
(setq *l* (nreverse *l*))
(show *l* #'cdr "rev ")
(gc)
(show *l* #'cdr "GCed"))
(defun makelflist (n &optional show)
(setq *lfl* (new-lockfree-list))
(dotimes (i n) (lfl-insert/fixnum *lfl* (* i n) (format nil "~r" i)))
(when show (show (list-head *lfl*) #'node-next "init"))
(gc)
(when show (show (list-head *lfl*) #'node-next "GCed"))
(logical-delete 1 *lfl*)
(logical-delete 4 *lfl*)
(gc :gen 2)
(when show (show (list-head *lfl*) #'node-next "del "))))
(test-util:with-test (:name :lockfree-list-gc-correctness)
;; Enable heap validity tester
(setf (sb-alien:extern-alien "verify_gens" char) 0)
;; Create a small list and perform logical deletion of 2 nodes
(makelflist 10)
(gc)) ; Verify no post-gc crash
(test-util:with-test (:name :lockfree-list-finalize-deletion)
;; Check that save-lisp-and-die can remove deleted nodes
(let ((list (new-lockfree-list)))
(lfl-insert/fixnum list 4 "four")
(lfl-insert/fixnum list 5 "five")
(logical-delete 0 list)
(logical-delete 1 list)
(finalize-deletion list)
(let* ((node (list-head list))
(next (node-next node)))
(assert (eq next (list-tail list))))))
;;; These functions are for comparing the running time of a lock-based
;;; implementation versus lockfree.
(defun new-synchronized-list ()
(list (sb-thread:make-mutex)))
(defun list-search (list key)
(let* (left
(this list)
(next (cdr this)))
(loop (setq left this this next)
(when (null this)
(return))
(setq next (cdr this))
(unless (< (truly-the fixnum (caar this)) key)
(return)))
(values this left)))
(defun locked-insert (list key value)
(sb-thread:with-mutex ((car list))
(multiple-value-bind (successor predecessor) (list-search list key)
(let ((new (cons (cons key value) successor)))
(rplacd predecessor new)))
list))
(defun locked-delete (list key)
(sb-thread:with-mutex ((car list))
(multiple-value-bind (this predecessor) (list-search list key)
(when (and this (= (caar this) key))
(rplacd predecessor (cdr this)))))
list)
;;;
(defglobal *worklist* nil)
(defmacro smoketest-macro (constructor inserter deleter)
`(let ((list ,constructor)
(threads))
(assert (<= n-threads 50))
(let ((max (* n-threads n-items)))
(dotimes (i n-threads)
(push (sb-thread:make-thread
(lambda (my-items &aux (ct 0))
(loop
(let ((val (atomic-pop *worklist*)))
(unless val (return))
(setf (aref my-items ct) val)
(,inserter list val (- val))
(incf ct)
(when (oddp ct)
(let ((item-to-delete
(aref my-items (floor ct 2))))
(,deleter list item-to-delete))))))
:arguments (make-array max))
threads)))
(dolist (thr threads) (sb-thread:join-thread thr))
list))
(defun smoketest-lockfree (n-threads n-items)
(smoketest-macro (new-lockfree-list) lfl-insert/fixnum lfl-delete/fixnum))
(defun smoketest-locked (n-threads n-items)
(smoketest-macro (new-synchronized-list)
locked-insert locked-delete))
(defun primitive-benchmark (&key (n-trials 3) (n-threads 10) (n-items 500) print)
(let ((best 0))
(dotimes (trial n-trials best)
(let* ((max (* n-threads n-items))
(worklist (test-util:shuffle (test-util:integer-sequence max)))
(random-state (make-random-state)))
(let ((rt0 (get-internal-real-time))
(rt1)
(rt2))
(setq *worklist* (copy-list worklist)
*random-state* (make-random-state random-state))
(smoketest-locked n-threads n-items)
(setq rt1 (get-internal-real-time))
(setq *worklist* (copy-list worklist)
*random-state* (make-random-state random-state))
(smoketest-lockfree n-threads n-items)
(setq rt2 (get-internal-real-time))
(let* ((et-locked (- rt1 rt0))
(et-lockfree (- rt2 rt1))
(ratio (/ et-locked et-lockfree)))
(when print
(format t "elapsed-times: locked=~d and lockfree=~d ratio=~f~%"
et-locked et-lockfree ratio))
(setq best (max ratio best))))))))
(test-util:with-test (:name :lockfree-list-performance)
(assert (> (primitive-benchmark)
;; should be able to get at least 2x speedup over lock-based code
2)))

5
tests/test-util.lisp
View file

@ -16,7 +16,7 @@
#:checked-compile-capturing-source-paths
#:checked-compile-condition-source-paths
#:runtime #:split-string #:shuffle))
#:runtime #:split-string #:integer-sequence #:shuffle))
(in-package :test-util)
@ -695,6 +695,9 @@
collect (subseq string begin end)
while end))
(defun integer-sequence (n)
(loop for i below n collect i))
(defun shuffle (sequence)
(typecase sequence
(list