diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 50ff8b6a14..f931bb1a95 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -237,6 +237,7 @@ EXPORTS scheme_make_hash_tree scheme_hash_tree_set scheme_hash_tree_get + scheme_eq_hash_tree_get scheme_hash_tree_next scheme_hash_tree_index scheme_hash_tree_equal diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 5b8a4a5d48..0ade8fb507 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -252,6 +252,7 @@ EXPORTS scheme_make_hash_tree scheme_hash_tree_set scheme_hash_tree_get + scheme_eq_hash_tree_get scheme_hash_tree_next scheme_hash_tree_index scheme_hash_tree_equal diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 9b2a7932fa..4065f5348f 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -254,6 +254,7 @@ scheme_clone_hash_table scheme_make_hash_tree scheme_hash_tree_set scheme_hash_tree_get +scheme_eq_hash_tree_get scheme_hash_tree_next scheme_hash_tree_index scheme_hash_tree_equal diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index de04422b20..03eab8c43d 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -260,6 +260,7 @@ scheme_clone_hash_table scheme_make_hash_tree scheme_hash_tree_set scheme_hash_tree_get +scheme_eq_hash_tree_get scheme_hash_tree_next scheme_hash_tree_index scheme_hash_tree_equal diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index 1442f9d114..b4d3174aec 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -1812,7 +1812,7 @@ static RBNode *recolor_rb(int red, RBNode *rb) rb->right); } -static RBNode *rb_find(uintptr_t code, RBNode *s) +XFORM_NONGCING static RBNode *rb_find(uintptr_t code, RBNode *s) { while (1) { if (!s) @@ -2411,6 +2411,31 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke return tree2; } +Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) +{ + uintptr_t h; + RBNode *rb; + + h = PTR_TO_LONG((Scheme_Object *)key); + + rb = rb_find(h, tree->root); + if (rb) { + if (!rb->key) { + /* Have list of keys & vals: */ + Scheme_Object *prs = rb->val, *a; + while (prs) { + a = SCHEME_CAR(prs); + if (SAME_OBJ(SCHEME_CAR(a), key)) + return SCHEME_CDR(a); + prs = SCHEME_CDR(prs); + } + } else + return rb->val; + } + + return NULL; +} + Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) { uintptr_t h; @@ -2423,7 +2448,7 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) else h = to_unsigned_hash(scheme_eqv_hash_key(key)); } else { - h = PTR_TO_LONG((Scheme_Object *)key); + return scheme_eq_hash_tree_get(tree, key); } rb = rb_find(h, tree->root); @@ -2433,31 +2458,23 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) Scheme_Object *prs = rb->val, *a; while (prs) { a = SCHEME_CAR(prs); - if (kind) { - if (kind == 1) { - if (scheme_equal(SCHEME_CAR(a), key)) - return SCHEME_CDR(a); - } else { - if (scheme_eqv(SCHEME_CAR(a), key)) - return SCHEME_CDR(a); - } + if (kind == 1) { + if (scheme_equal(SCHEME_CAR(a), key)) + return SCHEME_CDR(a); } else { - if (SAME_OBJ(SCHEME_CAR(a), key)) + if (scheme_eqv(SCHEME_CAR(a), key)) return SCHEME_CDR(a); } prs = SCHEME_CDR(prs); } } else { - if (kind) { - if (kind == 1) { - if (scheme_equal(key, rb->key)) - return rb->val; - } else { - if (scheme_eqv(key, rb->key)) - return rb->val; - } - } else if (SAME_OBJ(key, rb->key)) - return rb->val; + if (kind == 1) { + if (scheme_equal(key, rb->key)) + return rb->val; + } else { + if (scheme_eqv(key, rb->key)) + return rb->val; + } } } diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index d3e40df5bf..23762634c9 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -1258,6 +1258,20 @@ static int can_direct_native(Scheme_Object *p, int num_rands, intptr_t *extract_ return 0; } +static int is_noncm_hash_ref(Scheme_Object *rator, int num_rands, Scheme_App_Rec *app) +{ + /* hash-ref acts like a non-cm prim if there's no procedure 3rd argument */ + if (SAME_OBJ(rator, scheme_hash_ref_proc) && ((num_rands == 2) || (num_rands == 3))) { + if (num_rands == 3) { + if ((SCHEME_TYPE(app->args[3]) < _scheme_values_types_) + || SCHEME_PROCP(app->args[3])) + return 0; + } + return 1; + } + + return 0; +} static jit_direct_arg *check_special_direct_args(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, int args_already_in_place) @@ -1353,6 +1367,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ && ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa) || (((Scheme_Primitive_Proc *)rator)->mina < 0)) && (scheme_is_noncm(rator, jitter, 0, 0) + || is_noncm_hash_ref(rator, num_rands, app) /* It's also ok to directly call `values' if multiple values are ok: */ || (multi_ok && SAME_OBJ(rator, scheme_values_func)))) direct_prim = 1; diff --git a/src/racket/src/list.c b/src/racket/src/list.c index b96596b9ee..6505a18382 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -33,6 +33,7 @@ READ_ONLY Scheme_Object *scheme_mcons_proc; READ_ONLY Scheme_Object *scheme_list_proc; READ_ONLY Scheme_Object *scheme_list_star_proc; READ_ONLY Scheme_Object *scheme_box_proc; +READ_ONLY Scheme_Object *scheme_hash_ref_proc; /* read only locals */ ROSYM static Scheme_Object *weak_symbol; ROSYM static Scheme_Object *equal_symbol; @@ -582,11 +583,9 @@ scheme_init_list (Scheme_Env *env) "hash-set", 3, 3), env); - scheme_add_global_constant("hash-ref", - scheme_make_prim_w_arity(hash_table_get, - "hash-ref", - 2, 3), - env); + REGISTER_SO(scheme_hash_ref_proc); + scheme_hash_ref_proc = scheme_make_prim_w_arity(hash_table_get, "hash-ref", 2, 3); + scheme_add_global_constant("hash-ref", scheme_hash_ref_proc, env); scheme_add_global_constant("hash-remove!", scheme_make_noncm_prim(hash_table_remove_bang, "hash-remove!", @@ -2217,38 +2216,11 @@ static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[]) return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], argv[2]); } -static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]) +static Scheme_Object *hash_failed(int argc, Scheme_Object *argv[]) { Scheme_Object *v; - v = argv[0]; - - if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v)) - || SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v)) - || SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v)))) - v = scheme_chaperone_hash_get(v, argv[1]); - else if (SCHEME_BUCKTP(v)) { - Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v; - if (t->mutex) scheme_wait_sema(t->mutex, 0); - v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]); - if (t->mutex) scheme_post_sema(t->mutex); - } else if (SCHEME_HASHTRP(v)) { - v = scheme_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]); - } else if (!SCHEME_HASHTP(v)) { - scheme_wrong_type("hash-ref", "hash", 0, argc, argv); - return NULL; - } else if (((Scheme_Hash_Table *)v)->mutex) { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)v; - scheme_wait_sema(t->mutex, 0); - v = scheme_hash_get(t, argv[1]); - scheme_post_sema(t->mutex); - } else { - v = scheme_hash_get((Scheme_Hash_Table *)v, argv[1]); - } - - if (v) - return v; - else if (argc == 3) { + if (argc == 3) { v = argv[2]; if (SCHEME_PROCP(v)) return _scheme_tail_apply(v, 0, NULL); @@ -2262,6 +2234,70 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]) } } +static Scheme_Object *gen_hash_table_get(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v; + + v = argv[0]; + + if (SCHEME_HASHTP(v)) { + if (((Scheme_Hash_Table *)v)->mutex) { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)v; + scheme_wait_sema(t->mutex, 0); + v = scheme_hash_get(t, argv[1]); + scheme_post_sema(t->mutex); + } else { + v = scheme_hash_get((Scheme_Hash_Table *)v, argv[1]); + } + } else if (SCHEME_HASHTRP(v)) { + v = scheme_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]); + } else if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v)) + || SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v)) + || SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v)))) + v = scheme_chaperone_hash_get(v, argv[1]); + else if (SCHEME_BUCKTP(v)) { + Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v; + if (t->mutex) scheme_wait_sema(t->mutex, 0); + v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]); + if (t->mutex) scheme_post_sema(t->mutex); + } else { + scheme_wrong_type("hash-ref", "hash", 0, argc, argv); + return NULL; + } + + if (v) + return v; + else + return hash_failed(argc, argv); +} + +static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v; + + /* fast path is designed to avoid need for XFORM */ + v = argv[0]; + if (SCHEME_HASHTP(v)) { + if (!((Scheme_Hash_Table *)v)->make_hash_indices) { + v = scheme_eq_hash_get((Scheme_Hash_Table *)v, argv[1]); + if (v) + return v; + else + return hash_failed(argc, argv); + } + } else if (SCHEME_HASHTRP(v)) { + if (!(SCHEME_HASHTR_FLAGS(((Scheme_Hash_Tree *)v)) & 0x3)) { + v = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]); + if (v) + return v; + else + return hash_failed(argc, argv); + } + } + + return gen_hash_table_get(argc, argv); +} + static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]) { Scheme_Object *v; diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 3a9c415b28..eb457f0a8a 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -487,6 +487,7 @@ MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *bt); MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind); MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); +XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); MZ_EXTERN intptr_t scheme_hash_tree_next(Scheme_Hash_Tree *tree, intptr_t pos); MZ_EXTERN int scheme_hash_tree_index(Scheme_Hash_Tree *tree, intptr_t pos, Scheme_Object **_key, Scheme_Object **_val); MZ_EXTERN int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 2f13e9cfc3..fb19fe06c6 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -381,6 +381,7 @@ Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *bt); Scheme_Hash_Tree *(*scheme_make_hash_tree)(int kind); Scheme_Hash_Tree *(*scheme_hash_tree_set)(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); Scheme_Object *(*scheme_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key); +Scheme_Object *(*scheme_eq_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key); intptr_t (*scheme_hash_tree_next)(Scheme_Hash_Tree *tree, intptr_t pos); int (*scheme_hash_tree_index)(Scheme_Hash_Tree *tree, intptr_t pos, Scheme_Object **_key, Scheme_Object **_val); int (*scheme_hash_tree_equal)(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index d0f8141add..2d923213a1 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -285,6 +285,7 @@ scheme_extension_table->scheme_make_hash_tree = scheme_make_hash_tree; scheme_extension_table->scheme_hash_tree_set = scheme_hash_tree_set; scheme_extension_table->scheme_hash_tree_get = scheme_hash_tree_get; + scheme_extension_table->scheme_eq_hash_tree_get = scheme_eq_hash_tree_get; scheme_extension_table->scheme_hash_tree_next = scheme_hash_tree_next; scheme_extension_table->scheme_hash_tree_index = scheme_hash_tree_index; scheme_extension_table->scheme_hash_tree_equal = scheme_hash_tree_equal; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 42b3768038..115f8f7b99 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -285,6 +285,7 @@ #define scheme_make_hash_tree (scheme_extension_table->scheme_make_hash_tree) #define scheme_hash_tree_set (scheme_extension_table->scheme_hash_tree_set) #define scheme_hash_tree_get (scheme_extension_table->scheme_hash_tree_get) +#define scheme_eq_hash_tree_get (scheme_extension_table->scheme_eq_hash_tree_get) #define scheme_hash_tree_next (scheme_extension_table->scheme_hash_tree_next) #define scheme_hash_tree_index (scheme_extension_table->scheme_hash_tree_index) #define scheme_hash_tree_equal (scheme_extension_table->scheme_hash_tree_equal) diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 2563a87924..a5cd652dab 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -354,6 +354,7 @@ extern Scheme_Object *scheme_vector_proc; extern Scheme_Object *scheme_vector_immutable_proc; extern Scheme_Object *scheme_vector_ref_proc; extern Scheme_Object *scheme_vector_set_proc; +extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc;