diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index 7ad96dad3a..7b394c7e08 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -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; } } diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index c779758b72..7436a7a3ff 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -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; diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index 8f73bb2372..9edce7da65 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -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]); } diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 81a9922308..44b3963c29 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -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); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 11ed9fe871..d26f037d3d 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -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__ */ diff --git a/racket/src/racket/src/sema.c b/racket/src/racket/src/sema.c index 368208a568..9248347b89 100644 --- a/racket/src/racket/src/sema.c +++ b/racket/src/racket/src/sema.c @@ -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])) diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 7826f9bf7f..19bee742b6 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -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;