From 348e8f801ab659d84acfb49a5c7bbac63646e73a Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Wed, 14 Jan 2009 12:15:26 +0000
Subject: [PATCH] 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.

---
 rts/Schedule.c |    7 +++++++
 rts/Weak.c     |   11 +++++++++++
 rts/Weak.h     |    2 ++
 3 files changed, 20 insertions(+)

diff --git a/rts/Schedule.c b/rts/Schedule.c
index d22d48f..978adb8 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 a50a72e..17150f6 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 cf93b4d..8fccae2 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);
-- 
1.7.10.4