Detect when a C finalizer calls back to Haskell

This is illegal now, after the fix for #1364, but it turns out that
the existing check for dodgy callbacks doesn't catch finalizers
calling back, so we need another test.  This will be particularly
important for 6.10.2, because the behaviour has changed.

3 files changed, 20 insertions, 0 deletions

diff --git a/rts/Schedule.c b/rts/Schedule.c
index d22d48fb8f..978adb89c8 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -32,6 +32,7 @@
 #include "Proftimer.h"
 #include "ProfHeap.h"
 #include "GC.h"
+#include "Weak.h"
 
 /* PARALLEL_HASKELL includes go here */
 
@@ -281,6 +282,12 @@ schedule (Capability *initialCapability, Task *task)
 	      "### NEW SCHEDULER LOOP (task: %p, cap: %p)",
 	      task, initialCapability);
 
+  if (running_finalizers) {
+      errorBelch("error: a C finalizer called back into Haskell.\n"
+                 "   use Foreign.Concurrent.newForeignPtr for Haskell finalizers.");
+      stg_exit(EXIT_FAILURE);
+  }
+
   schedulePreLoop();
 
   // -----------------------------------------------------------
diff --git a/rts/Weak.c b/rts/Weak.c
index a50a72e59c..17150f6b3c 100644
--- a/rts/Weak.c
+++ b/rts/Weak.c
@@ -22,6 +22,9 @@
 
 StgWeak *weak_ptr_list;
 
+// So that we can detect when a finalizer illegally calls back into Haskell
+rtsBool running_finalizers = rtsFalse;
+
 void
 runCFinalizer(StgVoid *fn, StgVoid *ptr, StgVoid *env, StgWord flag)
 {
@@ -36,6 +39,8 @@ runAllCFinalizers(StgWeak *list)
 {
     StgWeak *w;
 
+    running_finalizers = rtsTrue;
+
     for (w = list; w; w = w->link) {
 	StgArrWords *farr;
 
@@ -47,6 +52,8 @@ runAllCFinalizers(StgWeak *list)
 	                  (StgVoid *)farr->payload[2],
 	                  farr->payload[3]);
     }
+
+    running_finalizers = rtsFalse;
 }
 
 /*
@@ -72,6 +79,8 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
     StgMutArrPtrs *arr;
     nat n;
 
+    running_finalizers = rtsTrue;
+
     // count number of finalizers, and kill all the weak pointers first...
     n = 0;
     for (w = list; w; w = w->link) { 
@@ -105,6 +114,8 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
 	SET_HDR(w, &stg_DEAD_WEAK_info, w->header.prof.ccs);
     }
 	
+    running_finalizers = rtsFalse;
+
     // No finalizers to run?
     if (n == 0) return;
 
diff --git a/rts/Weak.h b/rts/Weak.h
index cf93b4df9e..8fccae2a63 100644
--- a/rts/Weak.h
+++ b/rts/Weak.h
@@ -11,6 +11,8 @@
 
 #include "Capability.h"
 
+extern rtsBool running_finalizers;
+
 void runCFinalizer(StgVoid *fn, StgVoid *ptr, StgVoid *env, StgWord flag);
 void runAllCFinalizers(StgWeak *w);
 void scheduleFinalizers(Capability *cap, StgWeak *w);