mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

fix hash-set! on weak tables

Browse source 
* test-suite/tests/weaks.test: Add tests.
* libguile/hashtab.c (scm_hash_fn_set_x): Fix updates to weak-value hash
  tables to not deadlock inside the alloc lock.
This commit is contained in:
Andy Wingo 2011-06-16 12:06:43 +02:00
parent 589bc528bd
commit 636c99d42d
2 changed files with 55 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

51
libguile/hashtab.c
View file

@ -760,34 +760,36 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
return dflt; return dflt;
} }
struct weak_cdr_data
struct set_weak_cdr_data
{ {
SCM pair; SCM pair;
SCM new_val; SCM cdr;
}; };
static void* static void*
set_weak_cdr (void *data) get_weak_cdr (void *data)
{ {
struct set_weak_cdr_data *d = data; struct weak_cdr_data *d = data;
if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d->pair)) && !SCM_NIMP (d->new_val)) if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair))
{ d->cdr = SCM_BOOL_F;
GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (d->pair));
SCM_SETCDR (d->pair, d->new_val);
}
else else
{ d->cdr = SCM_CDR (d->pair);
SCM_SETCDR (d->pair, d->new_val);
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (d->pair),
(GC_PTR) SCM2PTR (d->new_val));
}
return NULL; return NULL;
} }
static SCM
weak_pair_cdr (SCM x)
{
struct weak_cdr_data data;
data.pair = x;
GC_call_with_alloc_lock (get_weak_cdr, &data);
return data.cdr;
}
SCM SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val, scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
@ -798,16 +800,21 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
pair = scm_hash_fn_create_handle_x (table, obj, val, pair = scm_hash_fn_create_handle_x (table, obj, val,
hash_fn, assoc_fn, closure); hash_fn, assoc_fn, closure);
if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair), val))) if (!scm_is_eq (SCM_CDR (pair), val))
{ {
if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table))) if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
{ {
struct set_weak_cdr_data data; /* If the former value was on the heap, we need to unregister
the weak link. */
SCM prev = weak_pair_cdr (pair);
data.pair = pair; SCM_SETCDR (pair, val);
data.new_val = val;
GC_call_with_alloc_lock (set_weak_cdr, &data); if (SCM_NIMP (prev) && !SCM_NIMP (val))
GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (pair));
else
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (pair),
(GC_PTR) SCM2PTR (val));
} }
else else
SCM_SETCDR (pair, val); SCM_SETCDR (pair, val);

26
test-suite/tests/weaks.test
View file

@ -1,5 +1,5 @@
;;;; weaks.test --- tests guile's weaks -*- scheme -*- ;;;; weaks.test --- tests guile's weaks -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -208,6 +208,30 @@
(hash-ref z test-key) (hash-ref z test-key)
#t)))) #t))))
(pass-if "hash-set!, weak val, im -> im"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" 1)
(hash-set! t "foo" 2)
(equal? (hash-ref t "foo") 2)))
(pass-if "hash-set!, weak val, im -> nim"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" 1)
(hash-set! t "foo" "baz")
(equal? (hash-ref t "foo") "baz")))
(pass-if "hash-set!, weak val, nim -> nim"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" "bar")
(hash-set! t "foo" "baz")
(equal? (hash-ref t "foo") "baz")))
(pass-if "hash-set!, weak val, nim -> im"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" "bar")
(hash-set! t "foo" 1)
(equal? (hash-ref t "foo") 1)))
(pass-if "assoc can do anything" (pass-if "assoc can do anything"
;; Until 1.9.12, as hash table's custom ASSOC procedure was ;; Until 1.9.12, as hash table's custom ASSOC procedure was
;; called with the GC lock alloc held, which imposed severe ;; called with the GC lock alloc held, which imposed severe