speed up `hash-ref'

by trimming the common-case path through a combination of small
 JIT and function changes

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

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

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

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

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 (kind == 1) {
+          if (scheme_equal(SCHEME_CAR(a), key))
-            if (scheme_equal(SCHEME_CAR(a), key))
+            return SCHEME_CDR(a);
-              return SCHEME_CDR(a);
-          } else {
-            if (scheme_eqv(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 (kind == 1) {
+        if (scheme_equal(key, rb->key))
-          if (scheme_equal(key, rb->key))
+          return rb->val;
-            return rb->val;
+      } else {
-        } else {
+        if (scheme_eqv(key, rb->key))
-          if (scheme_eqv(key, rb->key))
+          return rb->val;
-            return rb->val;
+      }
-        }
-      } else if (SAME_OBJ(key, rb->key))
-        return rb->val;
     }
   }
 

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;

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",
+  REGISTER_SO(scheme_hash_ref_proc);
-			     scheme_make_prim_w_arity(hash_table_get,
+  scheme_hash_ref_proc = scheme_make_prim_w_arity(hash_table_get, "hash-ref", 2, 3);
-						      "hash-ref",
+  scheme_add_global_constant("hash-ref", scheme_hash_ref_proc, env);
-						      2, 3),
-			     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 (argc == 3) {
-
-  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) {
     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;

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);

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);

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;

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)

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;