FIX #1364: added support for C finalizers that run as soon as the value is not longer reachable.

  
Patch originally by Ivan Tomac <tomac@pacific.net.au>, amended by
Simon Marlow:

  - mkWeakFinalizer# commoned up with mkWeakFinalizerEnv#
  - GC parameters to ALLOC_PRIM fixed

6 files changed, 120 insertions, 8 deletions

diff --git a/rts/Linker.c b/rts/Linker.c
index ac06cda1a9..ef12e3e9aa 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -224,6 +224,7 @@ typedef struct _RtsSymbolVal {
 
 #if !defined(PAR)
 #define Maybe_Stable_Names      SymI_HasProto(mkWeakzh_fast)			\
+      				SymI_HasProto(mkWeakForeignEnvzh_fast)		\
       				SymI_HasProto(makeStableNamezh_fast)		\
       				SymI_HasProto(finalizzeWeakzh_fast)
 #else
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index f75b8aaf16..40948a3ff4 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -297,9 +297,14 @@ mkWeakzh_fast
   w = Hp - SIZEOF_StgWeak + WDS(1);
   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 
-  StgWeak_key(w)       = R1;
-  StgWeak_value(w)     = R2;
-  StgWeak_finalizer(w) = R3;
+  // We don't care about cfinalizer here.
+  // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
+  // something else?
+
+  StgWeak_key(w)        = R1;
+  StgWeak_value(w)      = R2;
+  StgWeak_finalizer(w)  = R3;
+  StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
 
   StgWeak_link(w)	= W_[weak_ptr_list];
   W_[weak_ptr_list] 	= w;
@@ -309,12 +314,65 @@ mkWeakzh_fast
   RET_P(w);
 }
 
+mkWeakForeignEnvzh_fast
+{
+  /* R1 = key
+     R2 = value
+     R3 = finalizer
+     R4 = pointer
+     R5 = has environment (0 or 1)
+     R6 = environment
+  */
+  W_ w, payload_words, words, p;
+
+  W_ key, val, fptr, ptr, flag, eptr;
+
+  key  = R1;
+  val  = R2;
+  fptr = R3;
+  ptr  = R4;
+  flag = R5;
+  eptr = R6;
+
+  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakForeignEnvzh_fast );
+
+  w = Hp - SIZEOF_StgWeak + WDS(1);
+  SET_HDR(w, stg_WEAK_info, W_[CCCS]);
+
+  payload_words = 4;
+  words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
+  ("ptr" p)     = foreign "C" allocateLocal(MyCapability() "ptr", words) [];
+
+  TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+  SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+
+  StgArrWords_words(p)     = payload_words;
+  StgArrWords_payload(p,0) = fptr;
+  StgArrWords_payload(p,1) = ptr;
+  StgArrWords_payload(p,2) = eptr;
+  StgArrWords_payload(p,3) = flag;
+
+  // We don't care about the value here.
+  // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
+
+  StgWeak_key(w)        = key;
+  StgWeak_value(w)      = val;
+  StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
+  StgWeak_cfinalizer(w) = p;
+
+  StgWeak_link(w)   = W_[weak_ptr_list];
+  W_[weak_ptr_list] = w;
+
+  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
+
+  RET_P(w);
+}
 
 finalizzeWeakzh_fast
 {
   /* R1 = weak ptr
    */
-  W_ w, f;
+  W_ w, f, arr;
 
   w = R1;
 
@@ -342,9 +400,18 @@ finalizzeWeakzh_fast
   SET_INFO(w,stg_DEAD_WEAK_info);
   LDV_RECORD_CREATE(w);
 
-  f = StgWeak_finalizer(w);
+  f   = StgWeak_finalizer(w);
+  arr = StgWeak_cfinalizer(w);
+
   StgDeadWeak_link(w) = StgWeak_link(w);
 
+  if (arr != stg_NO_FINALIZER_closure) {
+    foreign "C" runCFinalizer(StgArrWords_payload(arr,0),
+                              StgArrWords_payload(arr,1),
+                              StgArrWords_payload(arr,2),
+                              StgArrWords_payload(arr,3)) [];
+  }
+
   /* return the finalizer */
   if (f == stg_NO_FINALIZER_closure) {
       RET_NP(0,stg_NO_FINALIZER_closure);
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index fbebdb9c41..6abeb404a0 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -414,6 +414,9 @@ hs_exit_(rtsBool wait_foreign)
 
     /* stop all running tasks */
     exitScheduler(wait_foreign);
+
+    /* run C finalizers for all active weak pointers */
+    runAllCFinalizers(weak_ptr_list);
     
 #if defined(GRAN)
     /* end_gr_simulation prints global stats if requested -- HWL */
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 7f7cf78f7b..639ac7e03a 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -435,16 +435,16 @@ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO")
    live weak pointers with dead ones).
    ------------------------------------------------------------------------- */
 
-INFO_TABLE(stg_WEAK,0,4,WEAK,"WEAK","WEAK")
+INFO_TABLE(stg_WEAK,1,4,WEAK,"WEAK","WEAK")
 { foreign "C" barf("WEAK object entered!") never returns; }
 
 /*
  * It's important when turning an existing WEAK into a DEAD_WEAK
  * (which is what finalizeWeak# does) that we don't lose the link
  * field and break the linked list of weak pointers.  Hence, we give
- * DEAD_WEAK 4 non-pointer fields, the same as WEAK.
+ * DEAD_WEAK 5 non-pointer fields.
  */
-INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,4,0,CONSTR,"DEAD_WEAK","DEAD_WEAK")
+INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK")
 { foreign "C" barf("DEAD_WEAK object entered!") never returns; }
 
 /* ----------------------------------------------------------------------------
diff --git a/rts/Weak.c b/rts/Weak.c
index e97ff57e9a..a50a72e59c 100644
--- a/rts/Weak.c
+++ b/rts/Weak.c
@@ -17,8 +17,38 @@
 #include "RtsAPI.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(StgVoid *fn, StgVoid *ptr, StgVoid *env, StgWord flag)
+{
+    if (flag)
+	((void (*)(void *, void *))fn)(env, ptr);
+    else
+	((void (*)(void *))fn)(ptr);
+}
+
+void
+runAllCFinalizers(StgWeak *list)
+{
+    StgWeak *w;
+
+    for (w = list; w; w = w->link) {
+	StgArrWords *farr;
+
+	farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
+
+	if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
+	    runCFinalizer((StgVoid *)farr->payload[0],
+	                  (StgVoid *)farr->payload[1],
+	                  (StgVoid *)farr->payload[2],
+	                  farr->payload[3]);
+    }
+}
+
 /*
  * scheduleFinalizers() is called on the list of weak pointers found
  * to be dead after a garbage collection.  It overwrites each object
@@ -45,6 +75,7 @@ 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.
@@ -54,6 +85,14 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
 	    n++;
 	}
 
+	farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
+
+	if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
+	    runCFinalizer((StgVoid *)farr->payload[0],
+	                  (StgVoid *)farr->payload[1],
+	                  (StgVoid *)farr->payload[2],
+	                  farr->payload[3]);
+
 #ifdef PROFILING
         // A weak pointer is inherently used, so we do not need to call
         // LDV_recordDead().
diff --git a/rts/Weak.h b/rts/Weak.h
index ba8c1ca913..cf93b4df9e 100644
--- a/rts/Weak.h
+++ b/rts/Weak.h
@@ -11,6 +11,8 @@
 
 #include "Capability.h"
 
+void runCFinalizer(StgVoid *fn, StgVoid *ptr, StgVoid *env, StgWord flag);
+void runAllCFinalizers(StgWeak *w);
 void scheduleFinalizers(Capability *cap, StgWeak *w);
 void markWeakList(void);