From f9630fa8b318f5d9fb939f1c60cb07cc9db7e9e4 Mon Sep 17 00:00:00 2001
From: Marius Gerbershagen <marius.gerbershagen@gmail.com>
Date: Tue, 20 Feb 2018 20:24:08 +0100
Subject: [PATCH] threading: fix race conditions in CLOS cache

    If a thread is interrupted after a call to fill_spec_vector, but
    before it can call ecl_search_cache, the cache may change during
    the interrupt, leading to crashes. We can't use
    env->disable_interrupts since fill_spec_vector calls methods which
    write in the thread-local environment. Disabling interrupts in
    ecl_search_cache and clear_list_from_cache is now redundant and
    has been removed.
---
 src/c/clos/accessor.d | 18 ++++++++++++------
 src/c/clos/cache.d    |  5 +----
 src/c/clos/gfun.d     | 36 +++++++++++++++++++-----------------
 src/h/internal.h      | 10 ++++++++++
 4 files changed, 42 insertions(+), 27 deletions(-)

diff --git a/src/c/clos/accessor.d b/src/c/clos/accessor.d
index b15e80a01..fe912879b 100644
--- a/src/c/clos/accessor.d
+++ b/src/c/clos/accessor.d
@@ -71,8 +71,12 @@ static ecl_cache_record_ptr
 search_slot_index(const cl_env_ptr env, cl_object gfun, cl_object instance)
 {
   ecl_cache_ptr cache = env->slot_cache;
-  fill_spec_vector(cache->keys, gfun, instance);
-  return ecl_search_cache(cache);
+  ecl_cache_record_ptr ret;
+  ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
+    fill_spec_vector(cache->keys, gfun, instance);
+    ret = ecl_search_cache(cache);
+  } ECL_WITHOUT_INTERRUPTS_END;
+  return ret;
 }
 
 static ecl_cache_record_ptr
@@ -89,10 +93,12 @@ add_new_index(const cl_env_ptr env, cl_object gfun, cl_object instance, cl_objec
   {
     ecl_cache_record_ptr e;
     ecl_cache_ptr cache = env->slot_cache;
-    fill_spec_vector(cache->keys, gfun, instance);
-    e = ecl_search_cache(cache);
-    e->key = cl_copy_seq(cache->keys);
-    e->value = index;
+    ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
+      fill_spec_vector(cache->keys, gfun, instance);
+      e = ecl_search_cache(cache);
+      e->key = cl_copy_seq(cache->keys);
+      e->value = index;
+    } ECL_WITHOUT_INTERRUPTS_END;
     return e;
   }
 }
diff --git a/src/c/clos/cache.d b/src/c/clos/cache.d
index 45fb79a37..0f66f2db3 100644
--- a/src/c/clos/cache.d
+++ b/src/c/clos/cache.d
@@ -56,7 +56,6 @@ clear_one_from_cache(ecl_cache_ptr cache, cl_object target)
 static void
 clear_list_from_cache(ecl_cache_ptr cache)
 {
-  ecl_disable_interrupts();
   cl_object list = ecl_atomic_get(&cache->clear_list);
   cl_object table = cache->table;
   cl_index i, total_size = table->vector.dim;
@@ -69,7 +68,6 @@ clear_list_from_cache(ecl_cache_ptr cache)
       }
     }
   }
-  ecl_enable_interrupts();
 }
 #endif
 
@@ -128,6 +126,7 @@ vector_hash_key(cl_object keys)
 /*
  * variation of ecl_gethash from hash.d, which takes an array of objects as key
  * It also assumes that entries are never removed except by clrhash.
+ * This method must be called with interrupts disabled!
  */
 
 ecl_cache_record_ptr
@@ -139,7 +138,6 @@ ecl_search_cache(ecl_cache_ptr cache)
   }
 #endif
   {
-    ecl_disable_interrupts();
     cl_object table = cache->table;
     cl_object keys = cache->keys;
     cl_index argno = keys->vector.fillp;
@@ -216,7 +214,6 @@ ecl_search_cache(ecl_cache_ptr cache)
         RECORD_GEN_SET(e, g);
       }
     }
-    ecl_enable_interrupts();
     return (ecl_cache_record_ptr)min_e;
   }
 }
diff --git a/src/c/clos/gfun.d b/src/c/clos/gfun.d
index b68becda4..959503439 100644
--- a/src/c/clos/gfun.d
+++ b/src/c/clos/gfun.d
@@ -232,25 +232,27 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
   }
 #endif
 
-  vector = fill_spec_vector(cache->keys, frame, gf);
-  e = ecl_search_cache(cache);
-  if (e->key != OBJNULL) {
-    func = e->value;
-  } else {
-    /* The keys and the cache may change while we
-     * compute the applicable methods. We must save
-     * the keys and recompute the cache location if
-     * it was filled. */
-    cl_object keys = cl_copy_seq(vector);
-    func = compute_applicable_method(env, frame, gf);
-    if (env->values[1] != ECL_NIL) {
-      if (e->key != OBJNULL) {
-        e = ecl_search_cache(cache);
+  ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
+    vector = fill_spec_vector(cache->keys, frame, gf);
+    e = ecl_search_cache(cache);
+    if (e->key != OBJNULL) {
+      func = e->value;
+    } else {
+      /* The keys and the cache may change while we
+       * compute the applicable methods. We must save
+       * the keys and recompute the cache location if
+       * it was filled. */
+      cl_object keys = cl_copy_seq(vector);
+      func = compute_applicable_method(env, frame, gf);
+      if (env->values[1] != ECL_NIL) {
+        if (e->key != OBJNULL) {
+          e = ecl_search_cache(cache);
+        }
+        e->key = keys;
+        e->value = func;
       }
-      e->key = keys;
-      e->value = func;
     }
-  }
+  } ECL_WITHOUT_INTERRUPTS_END;
   if (func == ECL_NIL)
     func = cl_apply(3, @'no-applicable-method', gf, frame);
   else
diff --git a/src/h/internal.h b/src/h/internal.h
index 1769552e0..6318a3962 100755
--- a/src/h/internal.h
+++ b/src/h/internal.h
@@ -522,6 +522,16 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock);
 
 extern void ecl_interrupt_process(cl_object process, cl_object function);
 
+/* disabling interrupts on the lisp side */
+
+#define ECL_WITHOUT_INTERRUPTS_BEGIN(the_env) do {                \
+        cl_env_ptr __the_env = (the_env);                         \
+        ecl_bds_bind(__the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
+
+#define ECL_WITHOUT_INTERRUPTS_END                 \
+        ecl_bds_unwind1(__the_env);                \
+        ecl_check_pending_interrupts(__the_env); } while(0)
+
 /* unixsys.d */
 
 /* Some old BSD systems don't have WCONTINUED / WIFCONTINUED */