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.

11 files changed, 110 insertions, 99 deletions

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 45472816c0..7203c11389 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1871,8 +1871,15 @@ primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
-primop  MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp
-   o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp
+   Addr# -> Addr# -> Int# -> Addr# -> Weak# b
+          -> State# RealWorld -> (# State# RealWorld, Int# #)
+   { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C
+     function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If
+     {\tt flag} is zero, {\tt fptr} will be called with one argument,
+     {\tt ptr}. Otherwise, it will be called with two arguments,
+     {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns
+     1 on success, or 0 if {\tt w} is already dead. }
    with
    has_side_effects = True
    out_of_line      = True
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
index 1eef182908..09e702149a 100644
--- a/includes/rts/storage/Closures.h
+++ b/includes/rts/storage/Closures.h
@@ -191,17 +191,21 @@ typedef struct _StgStableName {
 
 typedef struct _StgWeak {	/* Weak v */
   StgHeader header;
-  StgClosure *cfinalizer;
+  StgClosure *cfinalizers;
   StgClosure *key;
   StgClosure *value;		/* v */
   StgClosure *finalizer;
   struct _StgWeak *link;
 } StgWeak;
 
-typedef struct _StgDeadWeak {	/* Weak v */
+typedef struct _StgCFinalizerList {
   StgHeader header;
-  struct _StgWeak *link;
-} StgDeadWeak;
+  StgClosure *link;
+  void (*fptr)(void);
+  void *ptr;
+  void *eptr;
+  StgWord flag; /* has environment (0 or 1) */
+} StgCFinalizerList;
 
 /* Byte code objects.  These are fixed size objects with pointers to
  * four arrays, designed so that a BCO can be easily "re-linked" to
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index b9b4f2304f..db0a32eb67 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -412,7 +412,7 @@ RTS_FUN_DECL(stg_threadStatuszh);
 RTS_FUN_DECL(stg_mkWeakzh);
 RTS_FUN_DECL(stg_mkWeakNoFinalizzerzh);
 RTS_FUN_DECL(stg_mkWeakForeignzh);
-RTS_FUN_DECL(stg_mkWeakForeignEnvzh);
+RTS_FUN_DECL(stg_addCFinalizzerToWeakzh);
 RTS_FUN_DECL(stg_finalizzeWeakzh);
 RTS_FUN_DECL(stg_deRefWeakzh);
 
diff --git a/rts/Linker.c b/rts/Linker.c
index 47eb6b047a..43edde23f8 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -321,7 +321,7 @@ typedef struct _RtsSymbolVal {
 
 #define Maybe_Stable_Names      SymI_HasProto(stg_mkWeakzh)                     \
                                 SymI_HasProto(stg_mkWeakNoFinalizzerzh)         \
-                                SymI_HasProto(stg_mkWeakForeignEnvzh)           \
+                                SymI_HasProto(stg_addCFinalizzerToWeakzh)       \
                                 SymI_HasProto(stg_makeStableNamezh)             \
                                 SymI_HasProto(stg_finalizzeWeakzh)
 
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 {
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 28a41ad681..9484031832 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -439,6 +439,15 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK")
 { foreign "C" barf("DEAD_WEAK object entered!") never returns; }
 
 /* ----------------------------------------------------------------------------
+   C finalizer lists
+
+   Singly linked lists that chain multiple C finalizers on a weak pointer.
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALIZER_LIST")
+{ foreign "C" barf("C_FINALIZER_LIST object entered!") never returns; }
+
+/* ----------------------------------------------------------------------------
    NO_FINALIZER
 
    This is a static nullary constructor (like []) that we use to mark an empty
diff --git a/rts/Weak.c b/rts/Weak.c
index 5546514243..e7a1257562 100644
--- a/rts/Weak.c
+++ b/rts/Weak.c
@@ -16,18 +16,21 @@
 #include "Prelude.h"
 #include "Trace.h"
 
-// ForeignPtrs with C finalizers rely on weak pointers inside weak_ptr_list
-// to always be in the same order.
-
 StgWeak *weak_ptr_list;
 
 void
-runCFinalizer(void *fn, void *ptr, void *env, StgWord flag)
+runCFinalizers(StgCFinalizerList *list)
 {
-    if (flag)
-	((void (*)(void *, void *))fn)(env, ptr);
-    else
-	((void (*)(void *))fn)(ptr);
+    StgCFinalizerList *head;
+    for (head = list;
+        (StgClosure *)head != &stg_NO_FINALIZER_closure;
+        head = (StgCFinalizerList *)head->link)
+    {
+        if (head->flag)
+            ((void (*)(void *, void *))head->fptr)(head->eptr, head->ptr);
+        else
+            ((void (*)(void *))head->fptr)(head->ptr);
+    }
 }
 
 void
@@ -42,15 +45,7 @@ runAllCFinalizers(StgWeak *list)
     }
 
     for (w = list; w; w = w->link) {
-	StgArrWords *farr;
-
-	farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
-
-	if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
-	    runCFinalizer((void *)farr->payload[0],
-	                  (void *)farr->payload[1],
-	                  (void *)farr->payload[2],
-	                  farr->payload[3]);
+	runCFinalizers((StgCFinalizerList *)w->cfinalizers);
     }
 
     if (task != NULL) {
@@ -91,8 +86,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
     // count number of finalizers, and kill all the weak pointers first...
     n = 0;
     for (w = list; w; w = w->link) { 
-	StgArrWords *farr;
-
 	// Better not be a DEAD_WEAK at this stage; the garbage
 	// collector removes DEAD_WEAKs from the weak pointer list.
 	ASSERT(w->header.info != &stg_DEAD_WEAK_info);
@@ -101,13 +94,7 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
 	    n++;
 	}
 
-	farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
-
-	if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
-	    runCFinalizer((void *)farr->payload[0],
-	                  (void *)farr->payload[1],
-	                  (void *)farr->payload[2],
-	                  farr->payload[3]);
+	runCFinalizers((StgCFinalizerList *)w->cfinalizers);
 
 #ifdef PROFILING
         // A weak pointer is inherently used, so we do not need to call
diff --git a/rts/Weak.h b/rts/Weak.h
index 9b230f94de..7892277b11 100644
--- a/rts/Weak.h
+++ b/rts/Weak.h
@@ -16,7 +16,7 @@
 extern rtsBool running_finalizers;
 extern StgWeak * weak_ptr_list;
 
-void runCFinalizer(void *fn, void *ptr, void *env, StgWord flag);
+void runCFinalizers(StgCFinalizerList *list);
 void runAllCFinalizers(StgWeak *w);
 void scheduleFinalizers(Capability *cap, StgWeak *w);
 void markWeakList(void);
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 7c89418ab9..ffa355ae9c 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -620,7 +620,7 @@ thread_obj (StgInfoTable *info, StgPtr p)
     case WEAK:
     {
 	StgWeak *w = (StgWeak *)p;
-	thread(&w->cfinalizer);
+	thread(&w->cfinalizers);
 	thread(&w->key);
 	thread(&w->value);
 	thread(&w->finalizer);
diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c
index d57f7a094b..f8ccaad7ea 100644
--- a/rts/sm/MarkWeak.c
+++ b/rts/sm/MarkWeak.c
@@ -122,7 +122,7 @@ traverseWeakPtrList(void)
 	   * called on a live weak pointer object.  Just remove it.
 	   */
 	  if (w->header.info == &stg_DEAD_WEAK_info) {
-	      next_w = ((StgDeadWeak *)w)->link;
+	      next_w = w->link;
 	      *last_w = next_w;
 	      continue;
 	  }
@@ -144,7 +144,6 @@ traverseWeakPtrList(void)
                   next_w  = w->link;
 
                   // and put it on the new weak ptr list.
-                  // NB. we must retain the order of the weak_ptr_list (#7160)
                   if (weak_ptr_list == NULL) {
                       weak_ptr_list = w;
                   } else {
@@ -332,7 +331,7 @@ markWeakPtrList ( void )
       evacuate((StgClosure **)last_w);
       w = *last_w;
       if (w->header.info == &stg_DEAD_WEAK_info) {
-          last_w = &(((StgDeadWeak*)w)->link);
+          last_w = &(w->link);
       } else {
           last_w = &(w->link);
       }
diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs
index 78233a5b98..c731b9ea72 100644
--- a/utils/deriveConstants/DeriveConstants.hs
+++ b/utils/deriveConstants/DeriveConstants.hs
@@ -469,10 +469,14 @@ wanteds = concat
           ,closureField C "StgWeak" "key"
           ,closureField C "StgWeak" "value"
           ,closureField C "StgWeak" "finalizer"
-          ,closureField C "StgWeak" "cfinalizer"
-
-          ,closureSize  C "StgDeadWeak"
-          ,closureField C "StgDeadWeak" "link"
+          ,closureField C "StgWeak" "cfinalizers"
+
+          ,closureSize  C "StgCFinalizerList"
+          ,closureField C "StgCFinalizerList" "link"
+          ,closureField C "StgCFinalizerList" "fptr"
+          ,closureField C "StgCFinalizerList" "ptr"
+          ,closureField C "StgCFinalizerList" "eptr"
+          ,closureField C "StgCFinalizerList" "flag"
 
           ,closureSize  C "StgMVar"
           ,closureField C "StgMVar" "head"