[m-rev.] for review: Add thread.spawn_native/4 and thread.spawn/4.
Peter Wang
novalazy at gmail.com
Wed Jun 25 13:41:53 AEST 2014
Branches: master
Most backends already mapped Mercury threads to "native" threads in spawn/3,
but it was and remains an implementation detail. spawn_native provides
that behaviour as a documented feature for programs which require it,
including for the low-level C backend.
While we are at it, add a `thread' handle type. Some future uses
include: a place to hold a thread identifier; a handle for a
`thread.join' predicate if we want; a place to hold result values or
uncaught exceptions if we want.
library/thread.m:
Add abstract type `thread'. Currently just a dummy type.
Add can_spawn_native.
Add spawn_native/4. It can report failure to start a thread,
which was missing from the spawn/3 interface.
Add spawn/4 to match spawn_native/4, without the native thread
requirement.
Make ML_create_exclusive_thread wait for a success code from
the new thread before continuing.
runtime/mercury_thread.c:
Make MR_init_thread_inner and MR_setup_engine_for_threads
return errors instead of aborting on failure.
tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/spawn_native.exp2:
tests/hard_coded/spawn_native.exp:
tests/hard_coded/spawn_native.m:
Add test case.
NEWS:
Announce change.
diff --git a/NEWS b/NEWS
index 306f353..44d6279 100644
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,9 @@ Changes to the Mercury standard library:
* We have added a module that implements barriers for concurrent
programming. This module is a contribution from Mission Critical IT.
+* We have added thread.spawn_native/4 to dedicate an OS thread to a Mercury
+ thread. thread.spawn/4 was added as well.
+
Changes to the Mercury compiler:
* We have removed legacy support for the following systems:
diff --git a/library/thread.m b/library/thread.m
index b6b5e81..672a4cc 100644
--- a/library/thread.m
+++ b/library/thread.m
@@ -8,7 +8,7 @@
%-----------------------------------------------------------------------------%
%
% File: thread.m.
-% Main author: conway.
+% Authors: conway, wangp.
% Stability: medium.
%
% This module defines the Mercury concurrency interface.
@@ -24,6 +24,7 @@
:- interface.
:- import_module io.
+:- import_module maybe.
:- include_module barrier.
:- include_module channel.
@@ -32,17 +33,54 @@
%-----------------------------------------------------------------------------%
- % can_spawn succeeds if spawn/3 is supported in the current grade.
+ % Abstract type representing a thread.
+ %
+:- type thread.
+
+ % can_spawn succeeds if spawn/4 is supported in the current grade.
%
:- pred can_spawn is semidet.
+ % can_spawn_native succeeds if spawn_native/4 is supported in the current
+ % grade.
+ %
+:- pred can_spawn_native is semidet.
+
% spawn(Closure, IO0, IO) is true iff `IO0' denotes a list of I/O
% transactions that is an interleaving of those performed by `Closure'
% and those contained in `IO' - the list of transactions performed by
% the continuation of spawn/3.
%
-:- pred spawn(pred(io, io)::in(pred(di, uo) is cc_multi),
- io::di, io::uo) is cc_multi.
+ % Operationally, spawn/3 is like spawn/4 except that Closure does not
+ % accept a thread handle argument, and an exception is thrown if the
+ % thread cannot be created.
+ %
+:- pred spawn(pred(io, io), io, io).
+:- mode spawn(pred(di, uo) is cc_multi, di, uo) is cc_multi.
+
+ % spawn(Closure, Res, IO0, IO) creates a new thread and performs Closure in
+ % that thread. On success it returns ok(Thread) where Thread is a handle to
+ % the new thread. Otherwise it returns an error.
+ %
+:- pred spawn(pred(thread, io, io), maybe_error(thread), io, io).
+:- mode spawn(pred(in, di, uo) is cc_multi, out, di, uo) is cc_multi.
+
+ % spawn_native(Closure, Res, IO0, IO):
+ % Like spawn/4, but Closure will be performed in a separate "native thread"
+ % of the environment the program is running in (POSIX thread, Windows
+ % thread, Java thread, etc.).
+ %
+ % spawn_native exposes a low-level implementation detail, so it is more
+ % likely to change with the implementation.
+ %
+ % Rationale: on the low-level C backend Mercury threads are multiplexed
+ % onto a limited number of OS threads. A call to a blocking procedure
+ % prevents that OS thread from making progress on another Mercury thread.
+ % Some foreign code depends on OS thread-local state so needs to be
+ % consistently executed on a dedicated OS thread to be usable.
+ %
+:- pred spawn_native(pred(thread, io, io), maybe_error(thread), io, io).
+:- mode spawn_native(pred(in, di, uo) is cc_multi, out, di, uo) is cc_multi.
% yield(IO0, IO) is logically equivalent to (IO = IO0) but
% operationally, yields the Mercury engine to some other thread
@@ -56,19 +94,12 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- interface.
-
- % spawn_native(Closure, IO0, IO)
- % Currently only for testing.
- %
-:- pred spawn_native(pred(io, io)::in(pred(di, uo) is cc_multi),
- io::di, io::uo) is cc_multi.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
:- implementation.
+:- import_module bool.
+:- import_module require.
+:- import_module string.
+
:- pragma foreign_decl("C", "
#ifndef MR_HIGHLEVEL_CODE
#if (!defined(MR_EXEC_TRACE) && !defined(MR_DEEP_PROFILING)) || !defined(MR_USE_GCC_NONLOCAL_GOTOS)
@@ -91,32 +122,54 @@
#endif
").
+ % Nothing yet but it can be used to hold a thread id, joining, holding
+ % uncaught exception values, etc.
+:- type thread
+ ---> thread.
+
%-----------------------------------------------------------------------------%
+can_spawn :-
+ ( can_spawn_context
+ ; can_spawn_native
+ ).
+
+:- pred can_spawn_context is semidet.
+
+can_spawn_context :-
+ semidet_fail.
+
:- pragma foreign_proc("C",
- can_spawn,
+ can_spawn_context,
[will_not_call_mercury, promise_pure, may_not_duplicate],
"
#if !defined(MR_HIGHLEVEL_CODE)
SUCCESS_INDICATOR = MR_TRUE;
#else
+ SUCCESS_INDICATOR = MR_FALSE;
+#endif
+").
+
+:- pragma foreign_proc("C",
+ can_spawn_native,
+ [will_not_call_mercury, promise_pure],
+"
#if defined(MR_THREAD_SAFE)
SUCCESS_INDICATOR = MR_TRUE;
#else
SUCCESS_INDICATOR = MR_FALSE;
#endif
-#endif
").
:- pragma foreign_proc("C#",
- can_spawn,
+ can_spawn_native,
[will_not_call_mercury, promise_pure],
"
SUCCESS_INDICATOR = true;
").
:- pragma foreign_proc("Java",
- can_spawn,
+ can_spawn_native,
[will_not_call_mercury, promise_pure],
"
SUCCESS_INDICATOR = true;
@@ -124,17 +177,54 @@
%-----------------------------------------------------------------------------%
+spawn(Goal0, !IO) :-
+ Goal = (pred(_Thread::in, IO0::di, IO::uo) is cc_multi :- Goal0(IO0, IO)),
+ spawn(Goal, Res, !IO),
+ (
+ Res = ok(_)
+ ;
+ Res = error(Error),
+ unexpected($module, $pred, Error)
+ ).
+
+spawn(Goal, Res, !IO) :-
+ ( can_spawn_context ->
+ spawn_context(Goal, Res, !IO)
+ ;
+ spawn_native(Goal, Res, !IO)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred spawn_context(pred(thread, io, io), maybe_error(thread), io, io).
+:- mode spawn_context(pred(in, di, uo) is cc_multi, out, di, uo) is cc_multi.
+
+spawn_context(Goal, Res, !IO) :-
+ spawn_context_2(Goal, Success, !IO),
+ (
+ Success = yes,
+ Res = ok(thread)
+ ;
+ Success = no,
+ Res = error("Unable to spawn threads in this grade.")
+ ).
+
+:- pred spawn_context_2(pred(thread, io, io), bool, io, io).
+:- mode spawn_context_2(pred(in, di, uo) is cc_multi, out, di, uo) is cc_multi.
+
:- pragma foreign_proc("C",
- spawn(Goal::(pred(di, uo) is cc_multi), _IO0::di, _IO::uo),
+ spawn_context_2(Goal::(pred(in, di, uo) is cc_multi), Success::out,
+ _IO0::di, _IO::uo),
[promise_pure, will_not_call_mercury, thread_safe, tabled_for_io,
may_not_duplicate],
"
#if !defined(MR_HIGHLEVEL_CODE)
+{
MR_Context *ctxt;
ML_incr_thread_barrier_count();
- ctxt = MR_create_context(""spawn"", MR_CONTEXT_SIZE_REGULAR, NULL);
+ ctxt = MR_create_context(""spawn_context"", MR_CONTEXT_SIZE_REGULAR, NULL);
ctxt->MR_ctxt_resume = MR_ENTRY(mercury__thread__spawn_begin_thread);
/*
@@ -147,55 +237,71 @@
MR_clone_thread_local_mutables(MR_THREAD_LOCAL_MUTABLES);
MR_schedule_context(ctxt);
+ Success = MR_TRUE;
+}
#else /* MR_HIGHLEVEL_CODE */
+{
+ Success = MR_FALSE;
+}
+#endif /* MR_HIGHLEVEL_CODE */
+").
-#if defined(MR_THREAD_SAFE)
- ML_create_exclusive_thread(Goal);
+%-----------------------------------------------------------------------------%
+
+spawn_native(Goal, Res, !IO) :-
+ spawn_native_2(Goal, Success, !IO),
+ (
+ Success = yes,
+ Res = ok(thread)
+ ;
+ Success = no,
+ Res = error("Unable to create native thread.")
+ ).
+
+:- pred spawn_native_2(pred(thread, io, io), bool, io, io).
+:- mode spawn_native_2(pred(in, di, uo) is cc_multi, out, di, uo) is cc_multi.
+
+:- pragma foreign_proc("C",
+ spawn_native_2(Goal::(pred(in, di, uo) is cc_multi), Success::out,
+ _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe, tabled_for_io,
+ may_not_duplicate],
+"
+#ifdef MR_THREAD_SAFE
+ Success = ML_create_exclusive_thread(Goal);
#else
- MR_fatal_error(""spawn/3 requires a .par grade in high-level C grades."");
+ Success = MR_FALSE;
#endif
-
-#endif /* MR_HIGHLEVEL_CODE */
").
:- pragma foreign_proc("C#",
- spawn(Goal::(pred(di, uo) is cc_multi), _IO0::di, _IO::uo),
+ spawn_native_2(Goal::(pred(in, di, uo) is cc_multi), Success::out,
+ _IO0::di, _IO::uo),
[promise_pure, will_not_call_mercury, thread_safe, tabled_for_io,
may_not_duplicate],
"
+ try {
object[] thread_locals = runtime.ThreadLocalMutables.clone();
MercuryThread mt = new MercuryThread(Goal, thread_locals);
System.Threading.Thread thread = new System.Threading.Thread(
new System.Threading.ThreadStart(mt.execute_goal));
thread.Start();
+ Success = mr_bool.YES;
+ } catch (System.Threading.ThreadStartException e) {
+ Success = mr_bool.NO;
+ }
").
:- pragma foreign_proc("Java",
- spawn(Goal::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
+ spawn_native_2(Goal::(pred(in, di, uo) is cc_multi), Success::out,
+ _IO0::di, _IO::uo),
[promise_pure, will_not_call_mercury, thread_safe, tabled_for_io,
may_not_duplicate],
"
MercuryThread mt = new MercuryThread((Object[]) Goal);
Thread thread = new Thread(mt);
thread.start();
- IO = IO0;
-").
-
-%-----------------------------------------------------------------------------%
-
-spawn_native(_Goal, !IO) :-
- private_builtin.sorry("spawn_native").
-
-:- pragma foreign_proc("C",
- spawn_native(Goal::(pred(di, uo) is cc_multi), _IO0::di, _IO::uo),
- [promise_pure, will_not_call_mercury, thread_safe, tabled_for_io,
- may_not_duplicate],
-"
-#ifdef MR_THREAD_SAFE
- ML_create_exclusive_thread(Goal);
-#else
- MR_fatal_error(""spawn_native/3 requires a .par grade."");
-#endif
+ Success = bool.YES;
").
%-----------------------------------------------------------------------------%
@@ -338,54 +444,64 @@ INIT mercury_sys_init_thread_modules
#if defined(MR_THREAD_SAFE)
#include <pthread.h>
- int ML_create_exclusive_thread(MR_Word goal);
+ MR_bool ML_create_exclusive_thread(MR_Word goal);
void *ML_exclusive_thread_wrapper(void *arg);
typedef struct ML_ThreadWrapperArgs ML_ThreadWrapperArgs;
struct ML_ThreadWrapperArgs {
+ MercurySem sem;
MR_Word goal;
MR_ThreadLocalMuts *thread_local_mutables;
+ MR_bool thread_started;
};
#endif /* MR_THREAD_SAFE */
").
:- pragma foreign_code("C", "
#if defined(MR_THREAD_SAFE)
- int ML_create_exclusive_thread(MR_Word goal)
+ MR_bool ML_create_exclusive_thread(MR_Word goal)
{
- ML_ThreadWrapperArgs *args;
+ ML_ThreadWrapperArgs args;
pthread_t thread;
pthread_attr_t attrs;
-
- /*
- ** We can't allocate `args' on the stack because this function may return
- ** before the child thread has got all the information it needs out of the
- ** structure.
- */
- args = MR_GC_NEW_UNCOLLECTABLE(ML_ThreadWrapperArgs);
- args->goal = goal;
- args->thread_local_mutables =
- MR_clone_thread_local_mutables(MR_THREAD_LOCAL_MUTABLES);
+ int err;
ML_incr_thread_barrier_count();
+ sem_init(&args.sem, 0, 0);
+ args.goal = goal;
+ args.thread_local_mutables =
+ MR_clone_thread_local_mutables(MR_THREAD_LOCAL_MUTABLES);
+ args.thread_started = MR_FALSE;
+
pthread_attr_init(&attrs);
pthread_attr_setdetachstate(&attrs, PTHREAD_CREATE_DETACHED);
- if (pthread_create(&thread, &attrs, ML_exclusive_thread_wrapper, args)) {
- MR_fatal_error(""Unable to create thread."");
- }
+ err = pthread_create(&thread, &attrs, ML_exclusive_thread_wrapper, &args);
pthread_attr_destroy(&attrs);
+ if (err == 0) {
+ MR_SEM_WAIT(&args.sem, ""ML_create_exclusive_thread"");
+ }
+
+ sem_destroy(&args.sem);
+
+ if (args.thread_started) {
return MR_TRUE;
}
+ ML_decr_thread_barrier_count();
+ return MR_FALSE;
+ }
+
void *ML_exclusive_thread_wrapper(void *arg)
{
ML_ThreadWrapperArgs *args = arg;
MR_Word goal;
if (MR_init_thread(MR_use_now) == MR_FALSE) {
- MR_fatal_error(""Unable to init thread."");
+ args->thread_started = MR_FALSE;
+ MR_SEM_POST(&args->sem, ""ML_exclusive_thread_wrapper"");
+ return NULL;
}
/*
@@ -398,8 +514,12 @@ INIT mercury_sys_init_thread_modules
MR_assert(MR_THREAD_LOCAL_MUTABLES == NULL);
MR_SET_THREAD_LOCAL_MUTABLES(args->thread_local_mutables);
+ /*
+ ** Take a copy of the goal before telling the parent we are ready.
+ */
goal = args->goal;
- MR_GC_free(args);
+ args->thread_started = MR_TRUE;
+ MR_SEM_POST(&args->sem, ""ML_exclusive_thread_wrapper"");
ML_call_back_to_mercury_cc_multi(goal);
@@ -412,23 +532,20 @@ INIT mercury_sys_init_thread_modules
#endif /* MR_THREAD_SAFE */
").
-:- pred call_back_to_mercury(pred(io, io), io, io).
-:- mode call_back_to_mercury(pred(di, uo) is cc_multi, di, uo) is cc_multi.
+:- pred call_back_to_mercury(pred(thread, io, io), io, io).
+:- mode call_back_to_mercury(pred(in, di, uo) is cc_multi, di, uo) is cc_multi.
:- pragma foreign_export("C",
- call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
- "ML_call_back_to_mercury_cc_multi").
-:- pragma foreign_export("IL",
- call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
+ call_back_to_mercury(pred(in, di, uo) is cc_multi, di, uo),
"ML_call_back_to_mercury_cc_multi").
:- pragma foreign_export("C#",
- call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
+ call_back_to_mercury(pred(in, di, uo) is cc_multi, di, uo),
"ML_call_back_to_mercury_cc_multi").
:- pragma foreign_export("Java",
- call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
+ call_back_to_mercury(pred(in, di, uo) is cc_multi, di, uo),
"ML_call_back_to_mercury_cc_multi").
call_back_to_mercury(Goal, !IO) :-
- Goal(!IO).
+ Goal(thread, !IO).
%-----------------------------------------------------------------------------%
diff --git a/runtime/mercury_thread.c b/runtime/mercury_thread.c
index 1ca30df..7c8c876 100644
--- a/runtime/mercury_thread.c
+++ b/runtime/mercury_thread.c
@@ -53,7 +53,7 @@ MR_Integer MR_thread_barrier_count;
#endif
#ifdef MR_THREAD_SAFE
-static void
+static MR_bool
MR_setup_engine_for_threads(MercuryEngine *eng, MR_EngineType engine_type);
static void
MR_shutdown_engine_for_threads(MercuryEngine *eng);
@@ -105,7 +105,9 @@ MR_create_worksteal_thread_2(void *arg)
*/
MR_pin_thread();
#endif
- MR_init_thread_inner(MR_use_later, MR_ENGINE_TYPE_SHARED);
+ if (! MR_init_thread_inner(MR_use_later, MR_ENGINE_TYPE_SHARED)) {
+ MR_fatal_error("Unable to init shared engine thread.");
+ }
return NULL;
}
@@ -142,7 +144,10 @@ MR_init_thread_inner(MR_when_to_use when_to_use, MR_EngineType engine_type)
eng = MR_create_engine();
#ifdef MR_THREAD_SAFE
- MR_setup_engine_for_threads(eng, engine_type);
+ if (MR_setup_engine_for_threads(eng, engine_type) == MR_FALSE) {
+ MR_destroy_engine(eng);
+ return MR_FALSE;
+ }
assert(MR_thread_engine_base == NULL);
MR_set_thread_engine_base(eng);
MR_restore_registers();
@@ -221,9 +226,10 @@ MR_finalize_thread_engine(void)
** Additional setup/shutdown of the engine for threads support.
*/
-static void
+static MR_bool
MR_setup_engine_for_threads(MercuryEngine *eng, MR_EngineType engine_type)
{
+ MR_bool ok = MR_TRUE;
#ifndef MR_HIGHLEVEL_CODE
MR_EngineId min;
MR_EngineId max;
@@ -244,9 +250,8 @@ MR_setup_engine_for_threads(MercuryEngine *eng, MR_EngineType engine_type)
break;
}
}
- if (id == max) {
- MR_fatal_error("exhausted engine ids");
- }
+
+ if (id < max) {
if (MR_highest_engine_id < id) {
MR_highest_engine_id = id;
}
@@ -263,9 +268,19 @@ MR_setup_engine_for_threads(MercuryEngine *eng, MR_EngineType engine_type)
#ifdef MR_THREADSCOPE
MR_threadscope_setup_engine(eng);
#endif
+ } else {
+ #ifdef MR_DEBUG_THREADS
+ if (MR_debug_threads) {
+ fprintf(stderr, "Exhausted engine ids.\n");
+ }
+ #endif
+ ok = MR_FALSE;
+ }
MR_UNLOCK(&MR_all_engine_bases_lock, "MR_setup_engine_for_threads");
#endif
+
+ return ok;
}
static void
diff --git a/tests/hard_coded/Mercury.options b/tests/hard_coded/Mercury.options
index 157d31e..fe24ec1 100644
--- a/tests/hard_coded/Mercury.options
+++ b/tests/hard_coded/Mercury.options
@@ -73,6 +73,7 @@ MCFLAGS-reuse_double = --ctgc
MCFLAGS-reuse_ho = --ctgc --no-optimise-higher-order
MCFLAGS-sharing_comb = --ctgc --structure-sharing-widening 2
MCFLAGS-simplify_multi_arm_switch = -O3
+MCFLAGS-spawn_native = --no-ansi-c
MCFLAGS-string_substring = --no-warn-obsolete
MCFLAGS-type_info_const_inst = --const-struct --optimise-constant-propagation
MCFLAGS-uncond_reuse = --ctgc
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 4e94294..888e990 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -266,6 +266,7 @@ ORDINARY_PROGS= \
singleton_dups \
solve_quadratic \
space \
+ spawn_native \
special_char \
stable_sort \
static_no_tag \
diff --git a/tests/hard_coded/spawn_native.exp b/tests/hard_coded/spawn_native.exp
new file mode 100644
index 0000000..05335d5
--- /dev/null
+++ b/tests/hard_coded/spawn_native.exp
@@ -0,0 +1,8 @@
+a start
+b start
+c start
+d start
+a stop
+b stop
+c stop
+d stop
diff --git a/tests/hard_coded/spawn_native.exp2 b/tests/hard_coded/spawn_native.exp2
new file mode 100644
index 0000000..99e2742
--- /dev/null
+++ b/tests/hard_coded/spawn_native.exp2
@@ -0,0 +1 @@
+spawn_native not supported
diff --git a/tests/hard_coded/spawn_native.m b/tests/hard_coded/spawn_native.m
new file mode 100644
index 0000000..17c60c4
--- /dev/null
+++ b/tests/hard_coded/spawn_native.m
@@ -0,0 +1,181 @@
+%-----------------------------------------------------------------------------%
+
+:- module spawn_native.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+:- import_module string.
+:- import_module thread.
+
+:- pragma foreign_decl("C", local, "
+ #include <time.h>
+").
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ ( can_spawn_native ->
+ init_tl_key(!IO),
+ thread.spawn_native(go("a"), _, !IO),
+ msleep(100, !IO),
+ thread.spawn_native(go("b"), _, !IO),
+ msleep(100, !IO),
+ thread.spawn_native(go("c"), _, !IO),
+ msleep(100, !IO),
+ go("d", !IO)
+ ;
+ io.write_string("spawn_native not supported\n", !IO)
+ ).
+
+:- pred go(string::in, thread::in, io::di, io::uo) is cc_multi.
+
+go(Id, _, !IO) :-
+ go(Id, !IO),
+ cc_multi_equal(!IO).
+
+:- pred go(string::in, io::di, io::uo) is det.
+
+go(IdA, !IO) :-
+ set_tl(IdA, !IO),
+ io.write_string(IdA ++ " start\n", !IO),
+ msleep(500, !IO),
+ get_tl(IdB, !IO),
+ io.write_string(IdB ++ " stop\n", !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", local, "
+#ifdef MR_THREAD_SAFE
+ static MercuryThreadKey tl_key;
+#endif
+").
+
+:- pragma foreign_code("C#", "
+ [System.ThreadStatic]
+ private static string tl;
+").
+
+:- pragma foreign_code("Java", "
+ private static ThreadLocal<String> tl = new ThreadLocal<String>();
+").
+
+:- pred init_tl_key(io::di, io::uo) is det.
+
+init_tl_key(!IO).
+
+:- pragma foreign_proc("C",
+ init_tl_key(_IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+#ifdef MR_THREAD_SAFE
+ pthread_key_create(&tl_key, NULL);
+#endif
+").
+
+%-----------------------------------------------------------------------------%
+
+:- pred set_tl(string::in, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ set_tl(X::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+#ifdef MR_THREAD_SAFE
+ pthread_setspecific(tl_key, X);
+#endif
+").
+
+:- pragma foreign_proc("C#",
+ set_tl(X::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ tl = X;
+").
+
+:- pragma foreign_proc("Java",
+ set_tl(X::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ tl.set(X);
+").
+
+%-----------------------------------------------------------------------------%
+
+:- pred get_tl(string::out, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ get_tl(X::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+#ifdef MR_THREAD_SAFE
+ X = pthread_getspecific(tl_key);
+#endif
+").
+
+:- pragma foreign_proc("C#",
+ get_tl(X::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ X = tl;
+").
+
+:- pragma foreign_proc("Java",
+ get_tl(X::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ X = tl.get();
+").
+
+%-----------------------------------------------------------------------------%
+
+:- pred msleep(int::in, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ msleep(Msecs::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io,
+ may_not_duplicate],
+"
+#ifdef MR_WIN32
+ Sleep(Msecs);
+#else
+{
+ struct timespec req;
+ int err;
+
+ req.tv_sec = 0;
+ req.tv_nsec = Msecs * 1000000;
+ do {
+ err = nanosleep(&req, &req);
+ } while (err == -1 && errno == EINTR);
+}
+#endif
+").
+
+:- pragma foreign_proc("C#",
+ msleep(Msecs::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ System.Threading.Thread.Sleep(Msecs);
+").
+
+:- pragma foreign_proc("Java",
+ msleep(Msecs::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ try {
+ Thread.sleep(Msecs);
+ } catch (InterruptedException e) {
+ }
+").
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
--
1.8.4
More information about the reviews
mailing list