Allow multiple C finalizers to be attached to a Weak#

The commit replaces mkWeakForeignEnv# with addCFinalizerToWeak#.
This new primop mutates an existing Weak# object and adds a new
C finalizer to it.

This change removes an invariant in MarkWeak.c, namely that the relative
order of Weak# objects in the list needs to be preserved across GC. This
makes it easier to split the list into per-generation structures.

The patch also removes a race condition between two threads calling
finalizeWeak# on the same WEAK object at that same time.

1 files changed, 57 insertions, 56 deletions

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 01339b2a36..8d2bc2f0a9 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -374,14 +374,10 @@ stg_mkWeakzh ( gcptr key,
   w = Hp - SIZEOF_StgWeak + WDS(1);
   SET_HDR(w, stg_WEAK_info, CCCS);
 
-  // We don't care about cfinalizer here.
-  // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
-  // something else?
-
-  StgWeak_key(w)        = key;
-  StgWeak_value(w)      = value;
-  StgWeak_finalizer(w)  = finalizer;
-  StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
+  StgWeak_key(w)         = key;
+  StgWeak_value(w)       = value;
+  StgWeak_finalizer(w)   = finalizer;
+  StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
 
   ACQUIRE_LOCK(sm_mutex);
   StgWeak_link(w)       = W_[weak_ptr_list];
@@ -398,61 +394,62 @@ stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
   jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
 }
 
-stg_mkWeakForeignEnvzh ( gcptr key,
-                         gcptr val,
-                         W_ fptr,   // finalizer
-                         W_ ptr,
-                         W_ flag,   // has environment (0 or 1)
-                         W_ eptr )
+STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n")
+
+stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
+                             W_ ptr,
+                             W_ flag,   // has environment (0 or 1)
+                             W_ eptr,
+                             gcptr w )
 {
-  W_ payload_words, words;
-  gcptr w, p;
+  W_ c, info;
 
-  ALLOC_PRIM (SIZEOF_StgWeak);
+  ALLOC_PRIM (SIZEOF_StgCFinalizerList)
 
-  w = Hp - SIZEOF_StgWeak + WDS(1);
-  SET_HDR(w, stg_WEAK_info, CCCS);
+  c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
+  SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
 
-  payload_words = 4;
-  words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
-  ("ptr" p)     = ccall allocate(MyCapability() "ptr", words);
+  StgCFinalizerList_fptr(c) = fptr;
+  StgCFinalizerList_ptr(c) = ptr;
+  StgCFinalizerList_eptr(c) = eptr;
+  StgCFinalizerList_flag(c) = flag;
 
-  TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
-  SET_HDR(p, stg_ARR_WORDS_info, CCCS);
+  ("ptr" info) = ccall lockClosure(w "ptr");
 
-  StgArrWords_bytes(p)     = WDS(payload_words);
-  StgArrWords_payload(p,0) = fptr;
-  StgArrWords_payload(p,1) = ptr;
-  StgArrWords_payload(p,2) = eptr;
-  StgArrWords_payload(p,3) = flag;
+  if (info == stg_DEAD_WEAK_info) {
+    // Already dead.
+    unlockClosure(w, info);
+    return (0);
+  }
 
-  // We don't care about the value here.
-  // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
+  StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
+  StgWeak_cfinalizers(w) = c;
 
-  StgWeak_key(w)        = key;
-  StgWeak_value(w)      = val;
-  StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
-  StgWeak_cfinalizer(w) = p;
+  unlockClosure(w, info);
 
-  ACQUIRE_LOCK(sm_mutex);
-  StgWeak_link(w)   = W_[weak_ptr_list];
-  W_[weak_ptr_list] = w;
-  RELEASE_LOCK(sm_mutex);
+  recordMutable(w);
 
-  IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
+  IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
 
-  return (w);
+  return (1);
 }
 
 stg_finalizzeWeakzh ( gcptr w )
 {
-  gcptr f, arr;
+  gcptr f, list;
+  W_ info;
+
+  ("ptr" info) = ccall lockClosure(w "ptr");
 
   // already dead?
-  if (GET_INFO(w) == stg_DEAD_WEAK_info) {
+  if (info == stg_DEAD_WEAK_info) {
+      unlockClosure(w, info);
       return (0,stg_NO_FINALIZER_closure);
   }
 
+  f    = StgWeak_finalizer(w);
+  list = StgWeak_cfinalizers(w);
+
   // kill it
 #ifdef PROFILING
   // @LDV profiling
@@ -469,19 +466,12 @@ stg_finalizzeWeakzh ( gcptr w )
   //
   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
   //
-  SET_INFO(w,stg_DEAD_WEAK_info);
-  LDV_RECORD_CREATE(w);
+  unlockClosure(w, stg_DEAD_WEAK_info);
 
-  f   = StgWeak_finalizer(w);
-  arr = StgWeak_cfinalizer(w);
-
-  StgDeadWeak_link(w) = StgWeak_link(w);
+  LDV_RECORD_CREATE(w);
 
-  if (arr != stg_NO_FINALIZER_closure) {
-    ccall runCFinalizer(StgArrWords_payload(arr,0),
-                              StgArrWords_payload(arr,1),
-                              StgArrWords_payload(arr,2),
-                              StgArrWords_payload(arr,3));
+  if (list != stg_NO_FINALIZER_closure) {
+    ccall runCFinalizers(list);
   }
 
   /* return the finalizer */
@@ -494,10 +484,21 @@ stg_finalizzeWeakzh ( gcptr w )
 
 stg_deRefWeakzh ( gcptr w )
 {
-  W_ code;
+  W_ code, info;
   gcptr val;
 
-  if (GET_INFO(w) == stg_WEAK_info) {
+  info = GET_INFO(w);
+
+  if (info == stg_WHITEHOLE_info) {
+    // w is locked by another thread. Now it's not immediately clear if w is
+    // alive or not. We use lockClosure to wait for the info pointer to become
+    // something other than stg_WHITEHOLE_info.
+
+    ("ptr" info) = ccall lockClosure(w "ptr");
+    unlockClosure(w, info);
+  }
+
+  if (info == stg_WEAK_info) {
     code = 1;
     val = StgWeak_value(w);
   } else {