suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

streamline some paths for equality and hashing

Browse Source 
Cuts about 1/3 of the time for a string-hashing microbenchmark
provided by Pedro Ramos:

 #lang racket
 (define alphabet "abcdefghijklmnopqrstuvwxyz")
 (define (random-word n)
   (build-string n (lambda (x) (string-ref alphabet (random 26)))))
 (define words (for/list ([k 1000000])
                 (random-word 3)))
 (define d (make-hash))
 (time (for ([w (in-list words)])
         (if (hash-has-key? d w)
             (hash-set! d w (add1 (hash-ref d w)))
             (hash-set! d w 1))))
This commit is contained in:
Matthew Flatt 2014-07-24 11:48:44 +01:00
parent 0b7d96b854
commit c570a86201
7 changed files with 669 additions and 473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

658
racket/src/racket/src/bool.c
View File

@ -293,28 +293,34 @@ XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
return -1;
} else {
switch (t1) {
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_long_double_type) {
return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
case scheme_long_double_type:
return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
} else if (t1 == scheme_float_type) {
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
case scheme_float_type:
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
} else if (t1 == scheme_double_type) {
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
} else if (t1 == scheme_bignum_type)
return scheme_bignum_eq(obj1, obj2);
else if (t1 == scheme_rational_type)
return scheme_rational_eq(obj1, obj2);
else if (t1 == scheme_complex_type) {
Scheme_Complex *c1 = (Scheme_Complex *)obj1;
Scheme_Complex *c2 = (Scheme_Complex *)obj2;
return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
} else if (t1 == scheme_char_type)
return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
else
return -1;
case scheme_double_type:
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
case scheme_bignum_type:
return scheme_bignum_eq(obj1, obj2);
case scheme_rational_type:
return scheme_rational_eq(obj1, obj2);
case scheme_complex_type:
{
Scheme_Complex *c1 = (Scheme_Complex *)obj1;
Scheme_Complex *c2 = (Scheme_Complex *)obj2;
return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
}
case scheme_char_type:
return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
default:
return -1;
}
}
}
int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
@ -322,7 +328,93 @@ int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
return (is_eqv(obj1, obj2) > 0);
}
int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
{
Scheme_Type t1, t2;
int cmp;
cmp = is_eqv(obj1, obj2);
if (cmp > -1)
return cmp;
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2))
return -1;
switch (t1) {
case scheme_flvector_type:
{
intptr_t l1, l2, i;
l1 = SCHEME_FLVEC_SIZE(obj1);
l2 = SCHEME_FLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
SCHEME_FLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
}
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
{
intptr_t l1, l2, i;
l1 = SCHEME_EXTFLVEC_SIZE(obj1);
l2 = SCHEME_EXTFLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
SCHEME_EXTFLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
}
#endif
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_cpointer_type:
{
return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
== ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
}
case scheme_place_bi_channel_type:
{
Scheme_Place_Bi_Channel *bc1, *bc2;
bc1 = (Scheme_Place_Bi_Channel *)obj1;
bc2 = (Scheme_Place_Bi_Channel *)obj2;
return (SAME_OBJ(bc1->link->recvch, bc2->link->recvch)
&& SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
}
}
return -1;
}
int is_slow_equal (Scheme_Object *obj1, Scheme_Object *obj2)
{
Equal_Info eql;
@ -338,6 +430,17 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql);
}
int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
{
int v;
v = is_fast_equal(obj1, obj2, 0);
if (v > -1)
return v;
return is_slow_equal(obj1, obj2);
}
static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
{
Scheme_Object *v, *prev = obj1, *prev_prev = obj1;
@ -461,6 +564,10 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (cmp > -1)
return cmp;
cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
@ -484,272 +591,267 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
}
}
return 0;
} else if (t1 == scheme_pair_type) {
} else {
switch (t1) {
case scheme_pair_type:
{
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if (t1 == scheme_mutable_pair_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if ((t1 == scheme_vector_type)
|| (t1 == scheme_fxvector_type)) {
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
} else if (t1 == scheme_flvector_type) {
intptr_t l1, l2, i;
l1 = SCHEME_FLVEC_SIZE(obj1);
l2 = SCHEME_FLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
SCHEME_FLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_extflvector_type) {
intptr_t l1, l2, i;
l1 = SCHEME_EXTFLVEC_SIZE(obj1);
l2 = SCHEME_EXTFLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
SCHEME_EXTFLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
#endif
} else if ((t1 == scheme_byte_string_type)
|| ((t1 >= scheme_unix_path_type)
&& (t1 <= scheme_windows_path_type))) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
} else if (t1 == scheme_char_string_type) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
} else if (t1 == scheme_regexp_type) {
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
} else if ((t1 == scheme_structure_type)
|| (t1 == scheme_proc_struct_type)) {
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
goto top_after_next;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = orig_obj1;
a[1] = orig_obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
if (scheme_struct_is_transparent(obj1))
insp = NULL;
else {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
}
if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_mutable_pair_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_vector_type:
case scheme_fxvector_type:
{
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
}
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_regexp_type:
{
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
}
case scheme_structure_type:
case scheme_proc_struct_type:
{
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
goto top_after_next;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = orig_obj1;
a[1] = orig_obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
if (scheme_struct_is_transparent(obj1))
insp = NULL;
else {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
}
if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
} else
return 0;
}
}
}
case scheme_box_type:
{
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (SAME_OBJ(obj1, orig_obj1))
obj1 = SCHEME_BOX_VAL(obj1);
else
obj1 = scheme_unbox(orig_obj1);
if (SAME_OBJ(obj2, orig_obj2))
obj2 = SCHEME_BOX_VAL(obj2);
else
obj2 = scheme_unbox(orig_obj2);
goto top;
}
case scheme_hash_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
(Scheme_Hash_Table *)obj2, orig_obj2,
eql);
}
case scheme_hash_tree_type:
{
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
(Scheme_Hash_Tree *)obj2, orig_obj2,
eql);
}
case scheme_bucket_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
(Scheme_Bucket_Table *)obj2, orig_obj2,
eql);
}
case scheme_wrap_chunk_type: {
return vector_equal(obj1, obj1, obj2, obj2, eql);
}
case scheme_resolved_module_path_type:
{
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
}
case scheme_module_index_type:
{
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
} else
return 0;
}
default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
} else if (t1 == scheme_box_type) {
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (SAME_OBJ(obj1, orig_obj1))
obj1 = SCHEME_BOX_VAL(obj1);
else
obj1 = scheme_unbox(orig_obj1);
if (SAME_OBJ(obj2, orig_obj2))
obj2 = SCHEME_BOX_VAL(obj2);
else
obj2 = scheme_unbox(orig_obj2);
goto top;
} else if (t1 == scheme_hash_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
(Scheme_Hash_Table *)obj2, orig_obj2,
eql);
} else if (t1 == scheme_hash_tree_type) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
(Scheme_Hash_Tree *)obj2, orig_obj2,
eql);
} else if (t1 == scheme_bucket_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
(Scheme_Bucket_Table *)obj2, orig_obj2,
eql);
} else if (t1 == scheme_cpointer_type) {
return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
== ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
} else if (t1 == scheme_wrap_chunk_type) {
return vector_equal(obj1, obj1, obj2, obj2, eql);
} else if (t1 == scheme_resolved_module_path_type) {
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
} else if (t1 == scheme_module_index_type) {
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
} else
return 0;
} else if (t1 == scheme_place_bi_channel_type) {
Scheme_Place_Bi_Channel *bc1, *bc2;
bc1 = (Scheme_Place_Bi_Channel *)obj1;
bc2 = (Scheme_Place_Bi_Channel *)obj2;
return (SAME_OBJ(bc1->link->recvch, bc2->link->recvch)
&& SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
} else if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}

300
racket/src/racket/src/hash.c
View File

@ -228,16 +228,22 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
mask = table->size - 1;
if (table->make_hash_indices) {
GC_CAN_IGNORE intptr_t *_h2x;
if (table->compare) {
if (table->compare == scheme_compare_equal) {
h2 = 0;
_h2x = NULL;
} else
_h2x = &h2x;
table->make_hash_indices((void *)key, &hx, _h2x);
h = to_unsigned_hash(hx) & mask;
if (_h2x)
h2 = (to_unsigned_hash(h2x) & mask) | 1;
hx = scheme_equal_hash_key(key);
h = to_unsigned_hash(hx) & mask;
} else {
GC_CAN_IGNORE intptr_t *_h2x;
if (table->compare) {
h2 = 0;
_h2x = NULL;
} else
_h2x = &h2x;
table->make_hash_indices((void *)key, &hx, _h2x);
h = to_unsigned_hash(hx) & mask;
if (_h2x)
h2 = (to_unsigned_hash(h2x) & mask) | 1;
}
} else {
uintptr_t lkey;
lkey = PTR_TO_LONG((Scheme_Object *)key);
@ -246,32 +252,61 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
}
keys = table->keys;
if (table->compare) {
scheme_hash_request_count++;
while ((tkey = keys[h])) {
if (SAME_PTR(tkey, GONE)) {
if (set > 1) {
useme = h;
set = 1;
}
} else if (!table->compare(tkey, (char *)key)) {
if (set) {
table->vals[h] = val;
if (!val) {
keys[h] = GONE;
--table->count;
}
return val;
} else
return table->vals[h];
if (table->compare == scheme_compare_equal) {
/* Direct calls can be significant faster than indirect */
scheme_hash_request_count++;
while ((tkey = keys[h])) {
if (SAME_PTR(tkey, GONE)) {
if (set > 1) {
useme = h;
set = 1;
}
} else if (scheme_equal(tkey, key)) {
if (set) {
table->vals[h] = val;
if (!val) {
keys[h] = GONE;
--table->count;
}
return val;
} else
return table->vals[h];
}
scheme_hash_iteration_count++;
if (!h2) {
h2x = scheme_equal_hash_key2(key);
h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1;
}
h = (h + h2) & mask;
}
scheme_hash_iteration_count++;
if (!h2) {
table->make_hash_indices((void *)key, NULL, &h2x);
h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1;
} else {
scheme_hash_request_count++;
while ((tkey = keys[h])) {
if (SAME_PTR(tkey, GONE)) {
if (set > 1) {
useme = h;
set = 1;
}
} else if (!table->compare(tkey, (char *)key)) {
if (set) {
table->vals[h] = val;
if (!val) {
keys[h] = GONE;
--table->count;
}
return val;
} else
return table->vals[h];
}
scheme_hash_iteration_count++;
if (!h2) {
table->make_hash_indices((void *)key, NULL, &h2x);
h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1;
}
h = (h + h2) & mask;
}
h = (h + h2) & mask;
}
} else {
scheme_hash_request_count++;
@ -1162,21 +1197,13 @@ XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long_double d)
http://www.burtleburtle.net/bob/hash/doobs.html: */
#define MZ_MIX(k) (k += (k << 10), k ^= (k >> 6))
static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
XFORM_NONGCING static uintptr_t fast_equal_hash_key(Scheme_Object *o, uintptr_t k, int *_done)
{
Scheme_Type t;
Scheme_Object *orig_obj;
top:
orig_obj = o;
if (SCHEME_CHAPERONEP(o))
o = ((Scheme_Chaperone *)o)->val;
t = SCHEME_TYPE(o);
k += t;
if (hi->depth > (MAX_HASH_DEPTH << 1))
return k;
switch(t) {
case scheme_integer_type:
@ -1213,17 +1240,114 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
break;
case scheme_rational_type:
{
k += equal_hash_key(scheme_rational_numerator(o), 0, hi);
k += fast_equal_hash_key(scheme_rational_numerator(o), 0, _done);
o = scheme_rational_denominator(o);
break;
}
case scheme_complex_type:
{
Scheme_Complex *c = (Scheme_Complex *)o;
k += equal_hash_key(c->r, 0, hi);
k += fast_equal_hash_key(c->r, 0, _done);
o = c->i;
break;
}
case scheme_cpointer_type:
{
k = (k << 3) + k;
k += (uintptr_t)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o));
return k;
}
case scheme_char_type:
return k + SCHEME_CHAR_VAL(o);
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
int i = SCHEME_BYTE_STRLEN_VAL(o);
char *s = SCHEME_BYTE_STR_VAL(o);
while (i--) {
k += s[i];
MZ_MIX(k);
}
return k;
}
case scheme_char_string_type:
{
int i = SCHEME_CHAR_STRLEN_VAL(o);
mzchar *s = SCHEME_CHAR_STR_VAL(o);
while (i--) {
k += s[i];
MZ_MIX(k);
}
return k;
}
case scheme_regexp_type:
{
o = scheme_regexp_source(o);
break;
}
# ifndef MZ_PRECISE_GC
case scheme_keyword_type:
case scheme_symbol_type:
{
Scheme_Symbol *s = (Scheme_Symbol *)o;
if (!(MZ_OPT_HASH_KEY(&s->iso) & 0x1)) {
/* Interned. Make key depend only on the content. */
if (!(MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC)) {
int i, h = 0;
for (i = s->len; i--; ) {
h += (h << 5) + h + s->s[i];
}
h += (h << 2);
if (!(((short)h) & 0xFFFC))
h = 0x10;
MZ_OPT_HASH_KEY(&s->iso) |= (((short)h) & 0xFFFC);
}
return k + (MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC);
} else
return k + PTR_TO_LONG(o);
}
# endif
default:
{
*_done = 0;
return 0;
}
}
MZ_MIX(k);
goto top;
}
static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
{
Scheme_Type t;
Scheme_Object *orig_obj;
int done;
uintptr_t k2;
top:
orig_obj = o;
if (SCHEME_CHAPERONEP(o))
o = ((Scheme_Chaperone *)o)->val;
t = SCHEME_TYPE(o);
k += t;
if (hi->depth > (MAX_HASH_DEPTH << 1))
return k;
done = 1;
k2 = fast_equal_hash_key(o, k, &done);
if (done)
return k2;
switch(t) {
case scheme_pair_type:
{
# include "mzhashchk.inc"
@ -1245,12 +1369,6 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
o = SCHEME_CDR(o);
break;
}
case scheme_cpointer_type:
{
k = (k << 3) + k;
k += (uintptr_t)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o));
return k;
}
case scheme_vector_type:
case scheme_fxvector_type:
case scheme_wrap_chunk_type:
@ -1315,39 +1433,6 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
return k;
}
#endif
case scheme_char_type:
return k + SCHEME_CHAR_VAL(o);
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
int i = SCHEME_BYTE_STRLEN_VAL(o);
char *s = SCHEME_BYTE_STR_VAL(o);
while (i--) {
k += s[i];
MZ_MIX(k);
}
return k;
}
case scheme_char_string_type:
{
int i = SCHEME_CHAR_STRLEN_VAL(o);
mzchar *s = SCHEME_CHAR_STR_VAL(o);
while (i--) {
k += s[i];
MZ_MIX(k);
}
return k;
}
case scheme_regexp_type:
{
o = scheme_regexp_source(o);
break;
}
case scheme_structure_type:
case scheme_proc_struct_type:
{
@ -1544,29 +1629,14 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
return k;
}
# ifndef MZ_PRECISE_GC
case scheme_keyword_type:
case scheme_symbol_type:
case scheme_place_bi_channel_type:
{
Scheme_Symbol *s = (Scheme_Symbol *)o;
if (!(MZ_OPT_HASH_KEY(&s->iso) & 0x1)) {
/* Interned. Make key depend only on the content. */
if (!(MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC)) {
int i, h = 0;
for (i = s->len; i--; ) {
h += (h << 5) + h + s->s[i];
}
h += (h << 2);
if (!(((short)h) & 0xFFFC))
h = 0x10;
MZ_OPT_HASH_KEY(&s->iso) |= (((short)h) & 0xFFFC);
}
return k + (MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC);
} else
return k + PTR_TO_LONG(o);
k += 7;
/* a bi channel has sendch and recvch, but
sends are the same iff recvs are the same: */
o = (Scheme_Object *)((Scheme_Place_Bi_Channel *)o)->link->sendch;
}
# endif
break;
case scheme_resolved_module_path_type:
/* Needed for interning */
{
@ -1586,15 +1656,7 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
break;
}
break;
case scheme_place_bi_channel_type:
{
k += 7;
/* a bi channel has sendch and recvch, but
sends are the same iff recvs are the same: */
o = (Scheme_Object *)((Scheme_Place_Bi_Channel *)o)->link->sendch;
}
break;
default:
default:
{
Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t];
if (h1)
@ -1608,7 +1670,7 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
goto top;
}
intptr_t scheme_equal_hash_key(Scheme_Object *o)
static intptr_t slow_equal_hash_key(Scheme_Object *o)
{
Hash_Info hi;
@ -1619,6 +1681,18 @@ intptr_t scheme_equal_hash_key(Scheme_Object *o)
return to_signed_hash(equal_hash_key(o, 0, &hi));
}
intptr_t scheme_equal_hash_key(Scheme_Object *o)
{
uintptr_t k;
int done = 1;
k = fast_equal_hash_key(o, 0, &done);
if (done)
return to_signed_hash(k);
else
return slow_equal_hash_key(o);
}
intptr_t scheme_equal_hash_key2(Scheme_Object *o)
{
Hash_Info hi;

25
racket/src/racket/src/list.c
View File

@ -1795,7 +1795,7 @@ static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv)
return do_chaperone_box("impersonate-box", 1, argc, argv);
}
static int compare_equal(void *v1, void *v2)
int scheme_compare_equal(void *v1, void *v2)
{
return !scheme_equal((Scheme_Object *)v1, (Scheme_Object *)v2);
}
@ -1830,7 +1830,7 @@ Scheme_Bucket_Table *scheme_make_weak_equal_table(void)
sema = scheme_make_sema(1);
t->mutex = sema;
t->compare = compare_equal;
t->compare = scheme_compare_equal;
t->make_hash_indices = make_hash_indices_for_equal;
return t;
@ -1842,7 +1842,7 @@ Scheme_Bucket_Table *scheme_make_nonlock_equal_bucket_table(void)
t = scheme_make_bucket_table(20, SCHEME_hash_ptr);
t->compare = compare_equal;
t->compare = scheme_compare_equal;
t->make_hash_indices = make_hash_indices_for_equal;
return t;
@ -2023,7 +2023,7 @@ Scheme_Hash_Table *scheme_make_hash_table_equal()
sema = scheme_make_sema(1);
t->mutex = sema;
t->compare = compare_equal;
t->compare = scheme_compare_equal;
t->make_hash_indices = make_hash_indices_for_equal;
return t;
@ -2167,14 +2167,14 @@ Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[])
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o)) {
if ((((Scheme_Hash_Table *)o)->compare != compare_equal)
if ((((Scheme_Hash_Table *)o)->compare != scheme_compare_equal)
&& (((Scheme_Hash_Table *)o)->compare != compare_eqv))
return scheme_true;
} else if (SCHEME_HASHTRP(o)) {
if (!(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x3))
return scheme_true;
} else if (SCHEME_BUCKTP(o)) {
if ((((Scheme_Bucket_Table *)o)->compare != compare_equal)
if ((((Scheme_Bucket_Table *)o)->compare != scheme_compare_equal)
&& (((Scheme_Bucket_Table *)o)->compare != compare_eqv))
return scheme_true;
} else {
@ -2215,13 +2215,13 @@ Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[])
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o)) {
if (((Scheme_Hash_Table *)o)->compare == compare_equal)
if (((Scheme_Hash_Table *)o)->compare == scheme_compare_equal)
return scheme_true;
} else if (SCHEME_HASHTRP(o)) {
if (SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x1)
return scheme_true;
} else if (SCHEME_BUCKTP(o)) {
if (((Scheme_Bucket_Table *)o)->compare == compare_equal)
if (((Scheme_Bucket_Table *)o)->compare == scheme_compare_equal)
return scheme_true;
} else {
scheme_wrong_contract("hash-equal?", "hash?", 0, argc, argv);
@ -2249,7 +2249,7 @@ static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[])
int scheme_is_hash_table_equal(Scheme_Object *o)
{
return (((Scheme_Hash_Table *)o)->compare == compare_equal);
return (((Scheme_Hash_Table *)o)->compare == scheme_compare_equal);
}
int scheme_is_hash_table_eqv(Scheme_Object *o)
@ -2282,10 +2282,9 @@ static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[])
} else if (!SCHEME_HASHTP(v) || !SCHEME_MUTABLEP(v)) {
scheme_wrong_contract("hash-set!", "(and/c hash? (not/c immutable?))", 0, argc, argv);
} else if (((Scheme_Hash_Table *)v)->mutex) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
scheme_wait_sema(t->mutex, 0);
scheme_hash_set(t, argv[1], argv[2]);
scheme_post_sema(t->mutex);
scheme_wait_sema(((Scheme_Hash_Table *)v)->mutex, 0);
scheme_hash_set((Scheme_Hash_Table *)v, argv[1], argv[2]);
scheme_post_sema(((Scheme_Hash_Table *)v)->mutex);
} else {
scheme_hash_set((Scheme_Hash_Table *)v, argv[1], argv[2]);
}

9
racket/src/racket/src/schemef.h
View File

@ -1155,13 +1155,12 @@ MZ_EXTERN int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void
MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
MZ_EXTERN int scheme_is_list(Scheme_Object *obj1);
MZ_EXTERN int scheme_list_length(Scheme_Object *list);
MZ_EXTERN int scheme_proper_list_length(Scheme_Object *list);
XFORM_NONGCING MZ_EXTERN int scheme_is_list(Scheme_Object *obj1);
XFORM_NONGCING MZ_EXTERN int scheme_list_length(Scheme_Object *list);
XFORM_NONGCING MZ_EXTERN int scheme_proper_list_length(Scheme_Object *list);
MZ_EXTERN Scheme_Object *scheme_alloc_list(int size);
MZ_EXTERN Scheme_Object *scheme_map_1(Scheme_Object *(*f)(Scheme_Object*),
Scheme_Object *l);
MZ_EXTERN Scheme_Object *scheme_map_1(Scheme_Object *(*f)(Scheme_Object*), Scheme_Object *l);
MZ_EXTERN Scheme_Object *scheme_car(Scheme_Object *pair);
MZ_EXTERN Scheme_Object *scheme_cdr(Scheme_Object *pair);

4
racket/src/racket/src/schpriv.h
View File

@ -4039,7 +4039,7 @@ Scheme_Object *scheme_copy_list(Scheme_Object *l);
void scheme_reset_hash_table(Scheme_Hash_Table *ht, int *history);
Scheme_Object *scheme_regexp_source(Scheme_Object *re);
XFORM_NONGCING Scheme_Object *scheme_regexp_source(Scheme_Object *re);
int scheme_regexp_is_byte(Scheme_Object *re);
int scheme_regexp_is_pregexp(Scheme_Object *re);
Scheme_Object *scheme_make_regexp(Scheme_Object *str, int byte, int pcre, int * volatile result_is_err_string);
@ -4224,4 +4224,6 @@ void scheme_place_set_memory_use(intptr_t amt);
void scheme_place_check_memory_use();
void scheme_clear_place_ifs_stack();
int scheme_compare_equal(void *v1, void *v2);
#endif /* __mzscheme_private__ */

134
racket/src/racket/src/sema.c
View File

@ -308,69 +308,79 @@ static Scheme_Object *semap(int n, Scheme_Object **p)
return SCHEME_SEMAP(p[0]) ? scheme_true : scheme_false;
}
void did_post_sema(Scheme_Sema *t)
{
while (t->first) {
Scheme_Channel_Syncer *w;
int consumed;
w = t->first;
t->first = w->next;
if (!w->next)
t->last = NULL;
else
t->first->prev = NULL;
if ((!w->syncing || !w->syncing->result) && !pending_break(w->p)) {
if (w->syncing) {
w->syncing->result = w->syncing_i + 1;
if (w->syncing->disable_break)
w->syncing->disable_break->suspend_break++;
scheme_post_syncing_nacks(w->syncing);
if (!w->syncing->reposts || !w->syncing->reposts[w->syncing_i]) {
t->value -= 1;
consumed = 1;
} else
consumed = 0;
if (w->syncing->accepts && w->syncing->accepts[w->syncing_i])
scheme_accept_sync(w->syncing, w->syncing_i);
} else {
/* In this case, we will remove the syncer from line, but
someone else might grab the post. This is unfair, but it
can help improve throughput when multiple threads synchronize
on a lock. */
consumed = 1;
}
w->picked = 1;
} else
consumed = 0;
w->in_line = 0;
w->prev = NULL;
w->next = NULL;
if (w->picked) {
scheme_weak_resume_thread(w->p);
if (consumed)
break;
}
/* otherwise, loop to find one we can wake up */
}
}
static void sema_overflow()
{
scheme_raise_exn(MZEXN_FAIL,
"semaphore-post: the maximum post count has already been reached");
}
void scheme_post_sema(Scheme_Object *o)
{
/* fast path is designed to avoid need for XFORM */
Scheme_Sema *t = (Scheme_Sema *)o;
int v, consumed;
int v;
if (t->value < 0) return;
v = t->value + 1;
v = (intptr_t)((uintptr_t)t->value + 1);
if (v > t->value) {
t->value = v;
while (t->first) {
Scheme_Channel_Syncer *w;
w = t->first;
t->first = w->next;
if (!w->next)
t->last = NULL;
else
t->first->prev = NULL;
if ((!w->syncing || !w->syncing->result) && !pending_break(w->p)) {
if (w->syncing) {
w->syncing->result = w->syncing_i + 1;
if (w->syncing->disable_break)
w->syncing->disable_break->suspend_break++;
scheme_post_syncing_nacks(w->syncing);
if (!w->syncing->reposts || !w->syncing->reposts[w->syncing_i]) {
t->value -= 1;
consumed = 1;
} else
consumed = 0;
if (w->syncing->accepts && w->syncing->accepts[w->syncing_i])
scheme_accept_sync(w->syncing, w->syncing_i);
} else {
/* In this case, we will remove the syncer from line, but
someone else might grab the post. This is unfair, but it
can help improve throughput when multiple threads synchronize
on a lock. */
consumed = 1;
}
w->picked = 1;
} else
consumed = 0;
w->in_line = 0;
w->prev = NULL;
w->next = NULL;
if (w->picked) {
scheme_weak_resume_thread(w->p);
if (consumed)
break;
}
/* otherwise, loop to find one we can wake up */
}
return;
}
scheme_raise_exn(MZEXN_FAIL,
"semaphore-post: the maximum post count has already been reached");
if (t->first)
did_post_sema(t);
} else
sema_overflow();
}
void scheme_post_sema_all(Scheme_Object *o)
@ -619,7 +629,7 @@ static int try_channel(Scheme_Sema *sema, Syncing *syncing, int pos, Scheme_Obje
}
}
int scheme_try_plain_sema(Scheme_Object *o)
XFORM_NONGCING int scheme_try_plain_sema(Scheme_Object *o)
{
Scheme_Sema *sema = (Scheme_Sema *)o;
@ -944,15 +954,25 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci
return v;
}
int scheme_wait_sema(Scheme_Object *o, int just_try)
static int slow_wait_sema(Scheme_Object *o, int just_try)
{
Scheme_Object *a[1];
a[0] = o;
return scheme_wait_semas_chs(1, a, just_try, NULL);
}
int scheme_wait_sema(Scheme_Object *o, int just_try)
{
/* fast path is designed to avoid need for XFORM */
if (((just_try >= 0) || !scheme_current_thread->external_break)
&& scheme_try_plain_sema(o))
return 1;
return slow_wait_sema(o, just_try);
}
static Scheme_Object *block_sema_p(int n, Scheme_Object **p)
{
if (!SCHEME_SEMAP(p[0]))

12
racket/src/racket/src/thread.c
View File

@ -2176,7 +2176,7 @@ static Scheme_Object *current_thread_set(int argc, Scheme_Object *argv[])
-1, thread_set_p, "thread-group?", 0);
}
static TSET_IL void set_t_set_next(Scheme_Object *o, Scheme_Object *n)
XFORM_NONGCING static TSET_IL void set_t_set_next(Scheme_Object *o, Scheme_Object *n)
{
if (SCHEME_THREADP(o))
((Scheme_Thread *)o)->t_set_next = n;
@ -2184,7 +2184,7 @@ static TSET_IL void set_t_set_next(Scheme_Object *o, Scheme_Object *n)
((Scheme_Thread_Set *)o)->next = n;
}
static TSET_IL void set_t_set_prev(Scheme_Object *o, Scheme_Object *n)
XFORM_NONGCING static TSET_IL void set_t_set_prev(Scheme_Object *o, Scheme_Object *n)
{
if (SCHEME_THREADP(o))
((Scheme_Thread *)o)->t_set_prev = n;
@ -2192,7 +2192,7 @@ static TSET_IL void set_t_set_prev(Scheme_Object *o, Scheme_Object *n)
((Scheme_Thread_Set *)o)->prev = n;
}
static TSET_IL Scheme_Object *get_t_set_next(Scheme_Object *o)
XFORM_NONGCING static TSET_IL Scheme_Object *get_t_set_next(Scheme_Object *o)
{
if (SCHEME_THREADP(o))
return ((Scheme_Thread *)o)->t_set_next;
@ -2200,7 +2200,7 @@ static TSET_IL Scheme_Object *get_t_set_next(Scheme_Object *o)
return ((Scheme_Thread_Set *)o)->next;
}
static TSET_IL Scheme_Object *get_t_set_prev(Scheme_Object *o)
XFORM_NONGCING static TSET_IL Scheme_Object *get_t_set_prev(Scheme_Object *o)
{
if (SCHEME_THREADP(o))
return ((Scheme_Thread *)o)->t_set_prev;
@ -2208,7 +2208,7 @@ static TSET_IL Scheme_Object *get_t_set_prev(Scheme_Object *o)
return ((Scheme_Thread_Set *)o)->prev;
}
static void schedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
XFORM_NONGCING static void schedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
{
num_running_threads += 1;
@ -2227,7 +2227,7 @@ static void schedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
}
}
static void unschedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
XFORM_NONGCING static void unschedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
{
Scheme_Object *prev;
Scheme_Object *next;