gpgscm: Optimize environment lookups and insertions.

* tests/gpgscm/scheme.c (pointercmp): New function.
(new_slot_spec_in_env): Add and use slot for insertions.
(find_slot_spec_in_env): New variant of 'find_slot_in_env' that
returns the slot on failures.
(find_slot_in_env): Express using the new function.
(new_slot_in_env): Update callsite.
(opexe_0): Optimize lookup-or-insert.
(opexe_1): Likewise.
(scheme_define): Likewise.
--
Optimize environment lookups by keeping the lists in the hash table or
the list sorted.  Optimize the insertions by passing the slot computed
by the lookup to the insertion.

Signed-off-by: Justus Winter <justus@g10code.com>

tests/gpgscm/scheme.c

@@ -2612,6 +2612,22 @@ static int hash_fn(const char *key, int table_size)
 }
 #endif
 
+/* Compares A and B.  Returns an integer less than, equal to, or
+ * greater than zero if A is stored at a memory location that is
+ * numerical less than, equal to, or greater than that of B.  */
+static int
+pointercmp(pointer a, pointer b)
+{
+  uintptr_t a_n = (uintptr_t) a;
+  uintptr_t b_n = (uintptr_t) b;
+
+  if (a_n < b_n)
+    return -1;
+  if (a_n > b_n)
+    return 1;
+  return 0;
+}
+
 #ifndef USE_ALIST_ENV
 
 /*
@@ -2639,53 +2655,75 @@ static void new_frame_in_env(scheme *sc, pointer old_env)
   setenvironment(sc->envir);
 }
 
+/* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function.
+ *
+ * If SSLOT is NULL, the new slot is put into the appropriate place in
+ * the environment vector.  */
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-                                        pointer variable, pointer value)
+                                        pointer variable, pointer value,
+					pointer *sslot)
 {
 #define new_slot_spec_in_env_allocates	2
   pointer slot;
   gc_disable(sc, gc_reservations (new_slot_spec_in_env));
   slot = immutable_cons(sc, variable, value);
 
-  if (is_vector(car(env))) {
+  if (sslot == NULL) {
-    int location = hash_fn(symname(variable), vector_length(car(env)));
+    int location;
+    assert(is_vector(car(env)));
+    location = hash_fn(symname(variable), vector_length(car(env)));
 
     set_vector_elem(car(env), location,
                     immutable_cons(sc, slot, vector_elem(car(env), location)));
   } else {
-    car(env) = immutable_cons(sc, slot, car(env));
+    *sslot = immutable_cons(sc, slot, *sslot);
   }
   gc_enable(sc);
 }
 
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+/* Find the slot in ENV under the key HDL.  If ALL is given, look in
+ * all environments enclosing ENV.  If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT.
+ *
+ * SSLOT may be set to NULL if the new symbol should be placed at the
+ * appropriate place in the vector.  */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
 {
   pointer x,y;
   int location;
+  pointer *sl;
+  int d;
+  assert(is_symbol(hdl));
 
   for (x = env; x != sc->NIL; x = cdr(x)) {
     if (is_vector(car(x))) {
       location = hash_fn(symname(hdl), vector_length(car(x)));
+      sl = NULL;
       y = vector_elem(car(x), location);
     } else {
-      y = car(x);
+      sl = &car(x);
+      y = *sl;
     }
-    for ( ; y != sc->NIL; y = cdr(y)) {
+    for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) {
-              if (caar(y) == hdl) {
+      d = pointercmp(caar(y), hdl);
-                   break;
+      if (d == 0)
-              }
+	return car(y);		/* Hit.  */
-         }
+      else if (d > 0)
-         if (y != sc->NIL) {
+	break;			/* Miss.  */
-              break;
-         }
-         if(!all) {
-           return sc->NIL;
-         }
     }
-    if (x != sc->NIL) {
+
-          return car(y);
+    if (x == env && sslot)
-    }
+      *sslot = sl;		/* Insert here.  */
-    return sc->NIL;
+
+    if (!all)
+      return sc->NIL;		/* Miss, and stop looking.  */
+  }
+
+  return sc->NIL;		/* Not found in any environment.  */
 }
 
 #else /* USE_ALIST_ENV */
@@ -2696,41 +2734,66 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
   setenvironment(sc->envir);
 }
 
+/* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function.  */
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-                                        pointer variable, pointer value)
+                                        pointer variable, pointer value,
+					pointer *sslot)
 {
 #define new_slot_spec_in_env_allocates	2
-  car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
+  (void) env;
+  assert(is_symbol(variable));
+  *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot);
 }
 
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+/* Find the slot in ENV under the key HDL.  If ALL is given, look in
+ * all environments enclosing ENV.  If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT.  */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
 {
     pointer x,y;
+    pointer *sl;
+    int d;
+    assert(is_symbol(hdl));
+
     for (x = env; x != sc->NIL; x = cdr(x)) {
-         for (y = car(x); y != sc->NIL; y = cdr(y)) {
+      for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) {
-              if (caar(y) == hdl) {
+	d = pointercmp(caar(y), hdl);
-                   break;
+	if (d == 0)
-              }
+	  return car(y);	/* Hit.  */
-         }
+	else if (d > 0)
-         if (y != sc->NIL) {
+	  break;		/* Miss.  */
-              break;
+      }
-         }
+
-         if(!all) {
+      if (x == env && sslot)
-           return sc->NIL;
+	*sslot = sl;		/* Insert here.  */
-         }
+
+      if (!all)
+	return sc->NIL;		/* Miss, and stop looking.  */
     }
-    if (x != sc->NIL) {
+
-          return car(y);
+    return sc->NIL;		/* Not found in any environment.  */
-    }
-    return sc->NIL;
 }
 
 #endif /* USE_ALIST_ENV else */
 
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+  return find_slot_spec_in_env(sc, env, hdl, all, NULL);
+}
+
 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
 {
 #define new_slot_in_env_allocates	new_slot_spec_in_env_allocates
-  new_slot_spec_in_env(sc, sc->envir, variable, value);
+  pointer slot;
+  pointer *sslot;
+  assert(is_symbol(variable));
+  slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
+  assert(slot == sc->NIL);
+  new_slot_spec_in_env(sc, sc->envir, variable, value, sslot);
 }
 
 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
@@ -3486,15 +3549,16 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           s_save(sc,OP_DEF1, sc->NIL, x);
           s_thread_to(sc,OP_EVAL);
 
-     CASE(OP_DEF1):  /* define */
+     CASE(OP_DEF1): { /* define */
-          x=find_slot_in_env(sc,sc->envir,sc->code,0);
+	  pointer *sslot;
+          x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
           if (x != sc->NIL) {
                set_slot_in_env(sc, x, sc->value);
           } else {
-               new_slot_in_env(sc, sc->code, sc->value);
+	       new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
           }
           s_return(sc,sc->code);
-
+     }
 
      CASE(OP_DEFP):  /* defined? */
           x=sc->envir;
@@ -3806,15 +3870,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           s_save(sc,OP_MACRO1, sc->NIL, x);
           s_goto(sc,OP_EVAL);
 
-     CASE(OP_MACRO1):     /* macro */
+     CASE(OP_MACRO1): {   /* macro */
+	  pointer *sslot;
           typeflag(sc->value) = T_MACRO;
-          x = find_slot_in_env(sc, sc->envir, sc->code, 0);
+          x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
           if (x != sc->NIL) {
                set_slot_in_env(sc, x, sc->value);
           } else {
-               new_slot_in_env(sc, sc->code, sc->value);
+	       new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
           }
           s_return(sc,sc->code);
+     }
 
      CASE(OP_CASE0):      /* case */
           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
@@ -5769,12 +5835,12 @@ void scheme_load_string(scheme *sc, const char *cmd) {
 
 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
      pointer x;
-
+     pointer *sslot;
-     x=find_slot_in_env(sc,envir,symbol,0);
+     x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot);
      if (x != sc->NIL) {
           set_slot_in_env(sc, x, value);
      } else {
-          new_slot_spec_in_env(sc, envir, symbol, value);
+          new_slot_spec_in_env(sc, envir, symbol, value, sslot);
      }
 }