Add hs_thread_done() (#8124)

See documentation for details.

9 files changed, 137 insertions, 11 deletions

diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml
index 4d91947c72..e7d5a0c37d 100644
--- a/docs/users_guide/ffi-chap.xml
+++ b/docs/users_guide/ffi-chap.xml
@@ -213,6 +213,40 @@ newtype {-# CTYPE            "useconds_t" #-} T = ...
 </programlisting>
         </para>
       </sect2>
+
+      <sect2>
+        <title><literal>hs_thread_done()</literal></title>
+
+<programlisting>
+void hs_thread_done(void);
+</programlisting>
+
+        <para>
+          GHC allocates a small amount of thread-local memory when a
+          thread calls a Haskell function via a <literal>foreign
+          export</literal>.  This memory is not normally freed until
+          <literal>hs_exit()</literal>; the memory is cached so that
+          subsequent calls into Haskell are fast.  However, if your
+          application is long-running and repeatedly creates new
+          threads that call into Haskell, you probably want to arrange
+          that this memory is freed in those threads that have
+          finished calling Haskell functions.  To do this, call
+          <literal>hs_thread_done()</literal> from the thread whose
+          memory you want to free.
+        </para>
+
+        <para>
+          Calling <literal>hs_thread_done()</literal> is entirely
+          optional.  You can call it as often or as little as you
+          like.  It is safe to call it from a thread that has never
+          called any Haskell functions, or one that never will.  If
+          you forget to call it, the worst that can happen is that
+          some memory remains allocated until
+          <literal>hs_exit()</literal> is called.  If you call it too
+          often, the worst that can happen is that the next call to a
+          Haskell function incurs some extra overhead.
+        </para>
+      </sect2>
   </sect1>
 
   <sect1 id="ffi-ghc">
diff --git a/includes/HsFFI.h b/includes/HsFFI.h
index a21811efb5..ab3b3ebb23 100644
--- a/includes/HsFFI.h
+++ b/includes/HsFFI.h
@@ -150,6 +150,7 @@ extern void hs_init     (int *argc, char **argv[]);
 extern void hs_exit     (void);
 extern void hs_set_argv (int argc, char *argv[]);
 extern void hs_add_root (void (*init_root)(void));
+extern void hs_thread_done (void);
 
 extern void hs_perform_gc (void);
 
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index daae30b821..6e4decb8bd 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -223,6 +223,19 @@ void rts_checkSchedStatus (char* site, Capability *);
 
 SchedulerStatus rts_getSchedStatus (Capability *cap);
 
+/*
+ * The RTS allocates some thread-local data when you make a call into
+ * Haskell using one of the rts_eval() functions.  This data is not
+ * normally freed until hs_exit().  If you want to free it earlier
+ * than this, perhaps because the thread is about to exit, then call
+ * rts_done() from the thread.
+ *
+ * It is safe to make more rts_eval() calls after calling rts_done(),
+ * but the next one will cause allocation of the thread-local memory
+ * again.
+ */
+void rts_done (void);
+
 /* --------------------------------------------------------------------------
    Wrapper closures
 
diff --git a/rts/HsFFI.c b/rts/HsFFI.c
index 856536f5aa..8fae246111 100644
--- a/rts/HsFFI.c
+++ b/rts/HsFFI.c
@@ -11,6 +11,7 @@
 #include "Rts.h"
 
 #include "Stable.h"
+#include "Task.h"
 
 // hs_init and hs_exit are defined in RtsStartup.c
 
@@ -59,3 +60,9 @@ hs_free_fun_ptr(HsFunPtr fp)
     /* I simply *love* all these similar names... */
     freeHaskellFunctionPtr(fp);
 }
+
+void
+hs_thread_done(void)
+{
+    freeMyTask();
+}
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index 725bfeb0b5..f01a0efee8 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -614,3 +614,9 @@ rts_unlock (Capability *cap)
       traceTaskDelete(task);
     }
 }
+
+void rts_done (void)
+{
+    freeMyTask();
+}
+
diff --git a/rts/Task.c b/rts/Task.c
index a044bc3672..12c22c4b02 100644
--- a/rts/Task.c
+++ b/rts/Task.c
@@ -134,6 +134,44 @@ allocTask (void)
     }
 }
 
+void freeMyTask (void)
+{
+    Task *task;
+
+    task = myTask();
+
+    if (task == NULL) return;
+
+    if (!task->stopped) {
+        errorBelch(
+            "freeMyTask() called, but the Task is not stopped; ignoring");
+        return;
+    }
+
+    if (task->worker) {
+        errorBelch("freeMyTask() called on a worker; ignoring");
+        return;
+    }
+
+    ACQUIRE_LOCK(&all_tasks_mutex);
+
+    if (task->all_prev) {
+        task->all_prev->all_next = task->all_next;
+    } else {
+        all_tasks = task->all_next;
+    }
+    if (task->all_next) {
+        task->all_next->all_prev = task->all_prev;
+    }
+
+    taskCount--;
+
+    RELEASE_LOCK(&all_tasks_mutex);
+
+    freeTask(task);
+    setMyTask(NULL);
+}
+
 static void
 freeTask (Task *task)
 {
@@ -219,7 +257,7 @@ newInCall (Task *task)
         task->spare_incalls = incall->next;
         task->n_spare_incalls--;
     } else {
-        incall = stgMallocBytes((sizeof(InCall)), "newBoundTask");
+        incall = stgMallocBytes((sizeof(InCall)), "newInCall");
     }
 
     incall->tso = NULL;
diff --git a/rts/Task.h b/rts/Task.h
index 4e0e13e93c..cf70256326 100644
--- a/rts/Task.h
+++ b/rts/Task.h
@@ -37,12 +37,20 @@
    Ownership of Task
    -----------------
 
-   The OS thread named in the Task structure has exclusive access to
-   the structure, as long as it is the running_task of its Capability.
-   That is, if (task->cap->running_task == task), then task->id owns
-   the Task.  Otherwise the Task is owned by the owner of the parent
-   data structure on which it is sleeping; for example, if the task is
-   sleeping on spare_workers field of a Capability, then the owner of the
+   Task ownership is a little tricky.  The default situation is that
+   the Task is an OS-thread-local structure that is owned by the OS
+   thread named in task->id.  An OS thread not currently executing
+   Haskell code might call newBoundTask() at any time, which assumes
+   that it has access to the Task for the current OS thread.
+
+   The all_next and all_prev fields of a Task are owned by
+   all_tasks_mutex, which must also be taken if we want to create or
+   free a Task.
+
+   For an OS thread in Haskell, if (task->cap->running_task != task),
+   then the Task is owned by the owner of the parent data structure on
+   which it is sleeping; for example, if the task is sleeping on
+   spare_workers field of a Capability, then the owner of the
    Capability has access to the Task.
 
    When a task is migrated from sleeping on one Capability to another,
@@ -147,7 +155,7 @@ typedef struct Task_ {
     // on spare_workers.
     struct Task_ *next;
 
-    // Links tasks on the all_tasks list
+    // Links tasks on the all_tasks list; need ACQUIRE_LOCK(&all_tasks_mutex)
     struct Task_ *all_next;
     struct Task_ *all_prev;
 
@@ -169,16 +177,24 @@ extern Task *all_tasks;
 void initTaskManager (void);
 nat  freeTaskManager (void);
 
-// Create a new Task for a bound thread
-// Requires: sched_mutex.
+// Create a new Task for a bound thread.  This Task must be released
+// by calling boundTaskExiting.  The Task is cached in
+// thread-local storage and will remain even after boundTaskExiting()
+// has been called; to free the memory, see freeMyTask().
 //
 Task *newBoundTask (void);
 
 // The current task is a bound task that is exiting.
-// Requires: sched_mutex.
 //
 void boundTaskExiting (Task *task);
 
+// Free a Task if one was previously allocated by newBoundTask().
+// This is not necessary unless the thread that called newBoundTask()
+// will be exiting, or if this thread has finished calling Haskell
+// functions.
+//
+void freeMyTask(void);
+
 // Notify the task manager that a task has stopped.  This is used
 // mainly for stats-gathering purposes.
 // Requires: sched_mutex.
diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index d506d3a1ce..7f9e073ef4 100644
--- a/testsuite/tests/rts/Makefile
+++ b/testsuite/tests/rts/Makefile
@@ -84,6 +84,9 @@ T5435_dyn_asm :
 T6006_setup :
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T6006.hs
 
+T8124_setup :
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T6006.hs
+
 ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
 T7037_CONST = const
 else
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index dfa0e89801..d36cc21c91 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -199,3 +199,11 @@ test('T8209', [ only_ways(threaded_ways), ignore_output ],
 
 test('T8242', [ only_ways(threaded_ways), ignore_output ],
               compile_and_run, [''])
+
+test('T8124', [ omit_ways(prof_ways + ['ghci']),
+                 extra_clean(['T8124_c.o']),
+                 pre_cmd('$MAKE -s --no-print-directory T8124_setup') ],
+                 # The T8124_setup hack is to ensure that we generate
+                 # T8124_stub.h before compiling T8124_c.c, which
+                 # needs it.
+               compile_and_run, ['T8124_c.c -no-hs-main'])