[m-rev.] for review: avoid MR_call_engine in thread.spawn

[Peter Wang]

Pending bootchecks.


Estimated hours taken: 10
Branches: main

Change the implementation of thread.spawn in low-level C grades.  Previously it
called the thread goal (a closure) via an exported Mercury procedure.  The
problem with that is the call counts as a C -> Mercury call, and so goes via
MR_call_engine() which sets up a large stack frame on the Mercury engine's C
stack that won't be deallocated until the thread terminates.

This is unnecessary inefficient since we can call the thread goal directly
instead of via MR_call_engine().  The thread goal won't be returning to a C
foreign proc when it finishes, and we don't need MR_call_engine() reserving
C stack space for Mercury execution as any Mercury engine that is about to
execute the thread goal would have that reserved space already.

library/thread.m:
	As above.

tests/par_conj/Mmakefile:
tests/par_conj/spawn_many.exp:
tests/par_conj/spawn_many.m:
	Add test case.


Index: library/thread.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/thread.m,v
retrieving revision 1.7
diff -u -r1.7 thread.m
--- library/thread.m	21 Mar 2007 22:30:27 -0000	1.7
+++ library/thread.m	26 Apr 2007 05:17:17 -0000
@@ -80,8 +80,7 @@
 #if !defined(MR_HIGHLEVEL_CODE)
     MR_Context  *ctxt;
     ctxt = MR_create_context(""spawn"", MR_CONTEXT_SIZE_REGULAR, NULL);
-    ctxt->MR_ctxt_resume =
-        MR_ENTRY(mercury__thread__spawn_call_back_to_mercury_cc_multi);
+    ctxt->MR_ctxt_resume = MR_ENTRY(mercury__thread__spawn_begin_thread);
     
     /*
     ** Store the closure on the top of the new context's stack.
@@ -144,8 +143,8 @@
 */
 
 #ifndef MR_HIGHLEVEL_CODE
-    MR_define_extern_entry(
-        mercury__thread__spawn_call_back_to_mercury_cc_multi);
+    MR_define_extern_entry(mercury__thread__spawn_begin_thread);
+    MR_declare_label(mercury__thread__spawn_end_thread);
     MR_define_extern_entry(mercury__thread__yield_resume);
 #endif
 ").
@@ -154,18 +153,23 @@
 "
 #ifndef MR_HIGHLEVEL_CODE
 
+    MR_declare_entry(mercury__do_call_closure_1);
+
     MR_BEGIN_MODULE(thread_module)
-        MR_init_entry_ai(mercury__thread__spawn_call_back_to_mercury_cc_multi);
+        MR_init_entry_ai(mercury__thread__spawn_begin_thread);
+        MR_init_label(mercury__thread__spawn_end_thread);
         MR_init_entry_ai(mercury__thread__yield_resume);
     MR_BEGIN_CODE
 
-    MR_define_entry(mercury__thread__spawn_call_back_to_mercury_cc_multi);
+    MR_define_entry(mercury__thread__spawn_begin_thread);
+    {
+        /* Call the closure placed the top of the stack. */
+        MR_r1 = *MR_sp;
+        MR_noprof_call(MR_ENTRY(mercury__do_call_closure_1),
+            MR_LABEL(mercury__thread__spawn_end_thread));
+    }
+    MR_define_label(mercury__thread__spawn_end_thread);
     {
-        MR_save_registers();
-        /*
-        ** Get the closure from the top of the stack.
-        */
-        ML_call_back_to_mercury_cc_multi(*((MR_Word *)MR_sp));
         MR_destroy_context(MR_ENGINE(MR_eng_this_context));
         MR_ENGINE(MR_eng_this_context) = NULL;
         MR_runnext();
Index: tests/par_conj/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/par_conj/Mmakefile,v
retrieving revision 1.11
diff -u -r1.11 Mmakefile
--- tests/par_conj/Mmakefile	26 Apr 2007 04:39:09 -0000	1.11
+++ tests/par_conj/Mmakefile	26 Apr 2007 05:17:17 -0000
@@ -67,12 +67,24 @@
 	PROGS0 =
 endif
 
+ifneq "$(findstring par,$(GRADE))" ""
+	# These tests are to do with explicit threads rather than parallel
+	# conjunction, but the tests require multiple engines to be enabled,
+	# which was already set up in this directory.
+	#
+	THREAD_PROGS = \
+		spawn_many
+else
+	THREAD_PROGS =
+endif
+
 ifneq "$(findstring decldebug,$(GRADE))" ""
 	OBJ_PROGS =
 	PROGS =
 else
 	OBJ_PROGS =
-	PROGS = $(PROGS0) $(DEP_PAR_CONJ_PROGS) $(INDEP_PAR_CONJ_PROGS)
+	PROGS = $(PROGS0) $(DEP_PAR_CONJ_PROGS) $(INDEP_PAR_CONJ_PROGS) \
+		$(THREAD_PROGS)
 endif
 
 # `mmc --make' doesn't expect subdirectories to appear in targets.
@@ -122,14 +134,22 @@
 	{ [ -f $*.inp ] && cat $*.inp; } | $(ENGINES) ./$< > $@ 2>&1 || \
 		{ grep . $@ /dev/null; exit 1; }
 
+ifeq "$(filter hl% java% il%,$(GRADE))" ""
+
 # Run threads_hang with multiple OS threads in lowlevel parallel grades.
 # Repeat the test a few times in increase the chances of getting a deadlock.
-ifeq "$(filter hl% java% il%,$(GRADE))" ""
 threads_hang.out: threads_hang
 	for i in 1 2 3 4 5 6 7 8 9 10 ; do \
 		MERCURY_OPTIONS=-P10 ./threads_hang 2>&1 > threads_hang.out ||\
 			{ echo 'failed' > threads_hang.out; break; } \
 	done
+
+# Run spawn_many with smallish C stacks, so we don't need to spawn so many
+# threads to see the bug.
+spawn_many.out: spawn_many
+	ulimit -s 256 && $(ENGINES) ./spawn_many 2>&1 > spawn_many.out || \
+		{ grep . $@ /dev/null; exit 1; }
+
 endif
 
 #-----------------------------------------------------------------------------#
Index: tests/par_conj/spawn_many.exp
===================================================================
RCS file: tests/par_conj/spawn_many.exp
diff -N tests/par_conj/spawn_many.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/par_conj/spawn_many.exp	26 Apr 2007 05:17:17 -0000
@@ -0,0 +1 @@
+ok
Index: tests/par_conj/spawn_many.m
===================================================================
RCS file: tests/par_conj/spawn_many.m
diff -N tests/par_conj/spawn_many.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/par_conj/spawn_many.m	26 Apr 2007 05:17:17 -0000
@@ -0,0 +1,64 @@
+% vim: ft=mercury ts=4 sw=4 et
+% This program spawns many threads very quickly.  In an old implementation of
+% thread.spawn, each new Mercury thread would push a large C stack frame on the
+% executing Mercury engine's C stack.  When the engine hit a blocking call
+% (e.g. channel.get) it would switch to the next Mercury context waiting, which
+% would usually be the start of another Mercury thread, which pushes another
+% large C stack frame.  Soon the C stack would be exhausted.
+%
+:- module spawn_many.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module maybe.
+:- import_module string.
+:- import_module thread.
+:- import_module thread.channel.
+:- import_module unit.
+
+main(!IO) :-
+    NumSpawn = 5000,
+    channel.init(Channel, !IO),
+    loop(Channel, NumSpawn, !IO),
+    count(Channel, 0, NumExit, !IO),
+    (if NumSpawn = NumExit then
+        io.write_string("ok\n", !IO)
+    else
+        io.format("not ok: %d != %d\n", [i(NumSpawn), i(NumExit)], !IO)
+    ).
+
+:- pred loop(channel(unit)::in, int::in, io::di, io::uo) is cc_multi.
+
+loop(Channel, N, !IO) :-
+    ( if N = 0 then
+        true
+    else
+        thread.spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+            foo(Channel, !IO)
+        ), !IO),
+        loop(Channel, N-1, !IO)
+    ).
+
+:- pred foo(channel(unit)::in, io::di, io::uo) is det.
+
+foo(Channel, !IO) :-
+    channel.put(Channel, unit, !IO).
+
+:- pred count(channel(unit)::in, int::in, int::out, io::di, io::uo) is det.
+
+count(Channel, Num0, Num, !IO) :-
+    channel.try_take(Channel, MaybeUnit, !IO),
+    (
+        MaybeUnit = yes(_),
+        count(Channel, Num0 + 1, Num, !IO)
+    ;
+        MaybeUnit = no,
+        Num = Num0
+    ).
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------