[m-rev.] for review: parallel mmc make
Peter Wang
wangp at students.csse.unimelb.edu.au
Fri Feb 9 15:25:56 AEDT 2007
Branches: main
Add initial support for parallel make functionality in `mmc --make', using
Mercury threads (not processes). Currently this is limited to running the
"compile target code to object code" step in parallel.
configure.in:
Require that the bootstrap compiler support the `thread_local'
attribute on mutables.
compiler/globals.m:
Use a thread-local mutable to hold the compiler's globals instead of
the globals facility in the io module.
Make the `extra_error_info' mutable thread-local.
compiler/options.m:
doc/user_guide.texi:
Add a `--parallel-jobs <n>' option.
compiler/make.util.m:
Add a `foldl2_maybe_stop_at_error_maybe_parallel' predicate which is
like `foldl2_maybe_stop_at_error' but capable of running tasks in
parallel depending on the `--parallel-jobs' option.
compiler/make.program_target.m:
Use `foldl2_maybe_stop_at_error_maybe_parallel' for the "target code to
object code" step.
library/io.m:
Make the current input/output streams thread-local in C grades. This
uses the same underlying mechanisms as thread-local mutables. Direct
references to the current stream variables are replaced by calls to
functions which work with the thread-local current streams instead.
Add a mutex and locking predicates to protect the stream_db structure.
Mark `get_stream_db' and `set_stream_db' as thread-safe and protect
calls to those predicates with the locking predicates.
Rename the impure version of `get_stream_db' to
`get_stream_db_with_locking' and make it acquire and release the
stream_db mutex.
Add a mutex to protect the `ML_next_stream_id' counter.
Add a note about a thread-safety problem in `io.get_system_error'.
Mark `io.call_system_code' as `thread_safe'.
library/list.m:
Add the predicate `list.split_upto', which is to `list.split_list' as
`list.take_upto' is to `list.take'.
library/stream.string_writer.m:
Conform to the renaming of the impure `io.get_stream_db'.
library/thread.m:
Add a predicate `can_spawn', which succeeds if `spawn' is supported in
the current grade.
NEWS:
Announce parallel make support.
Announce `list.split_upto'.
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.442
diff -u -r1.442 NEWS
--- NEWS 5 Feb 2007 03:12:50 -0000 1.442
+++ NEWS 7 Feb 2007 02:04:42 -0000
@@ -35,6 +35,7 @@
list.foldl2_corresponding3/8
list.foldl3_corresponding3/10
list.foldl4_corresponding3/12
+ list.split_upto/4
We have also added versions of list.foldl/4 and list.foldr/4 that have
determinism multi.
@@ -80,6 +81,9 @@
* The compiler now issues a warning when an inst declaration is not
consistent with any of the types in scope.
+* We have added some initial support for simultaneous execution of jobs in
+ `mmc --make'.
+
Changes to the Mercury deep profiler:
* The deep profiler now supports measuring a proxy for time: a counter that
@@ -156,6 +160,9 @@
This makes it easier to diagnose mode errors caused by insts that are not
consistent with the type they are intended to be consistent with.
+* Simultaneous execution of jobs with `mmc --make' can be enabled with
+ the `--parallel-jobs <n>' option.
+
Changes to the Mercury standard library:
* The predicates io.seek_binary/5 and io.binary_stream_offset/4 have been
Index: configure.in
===================================================================
RCS file: /home/mercury1/repository/mercury/configure.in,v
retrieving revision 1.486
diff -u -r1.486 configure.in
--- configure.in 6 Feb 2007 00:56:45 -0000 1.486
+++ configure.in 7 Feb 2007 00:14:01 -0000
@@ -222,7 +222,7 @@
int,
561,
ground,
- [[untrailed, attach_to_io_state]]
+ [[untrailed, attach_to_io_state, thread_local]]
).
main(!IO) :-
Index: compiler/globals.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/globals.m,v
retrieving revision 1.79
diff -u -r1.79 globals.m
--- compiler/globals.m 8 Jan 2007 03:03:09 -0000 1.79
+++ compiler/globals.m 16 Jan 2007 23:48:55 -0000
@@ -362,11 +362,14 @@
may_be_thread_safe :: bool
).
+:- mutable(globals, univ, univ(0), ground,
+ [untrailed, attach_to_io_state, thread_local]).
+
% Is there extra information about errors available that could be printed
% out if `-E' were enabled.
%
:- mutable(extra_error_info, bool, no, ground,
- [untrailed, attach_to_io_state]).
+ [untrailed, attach_to_io_state, thread_local]).
globals_init(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel, TraceSuppress,
@@ -569,7 +572,7 @@
get_extra_error_info(ExtraErrorInfo, !IO).
io_get_globals(Globals, !IO) :-
- io.get_globals(UnivGlobals, !IO),
+ globals.get_globals(UnivGlobals, !IO),
( univ_to_type(UnivGlobals, Globals0) ->
Globals = Globals0
;
@@ -578,7 +581,7 @@
io_set_globals(Globals, !IO) :-
type_to_univ(Globals, UnivGlobals),
- io.set_globals(UnivGlobals, !IO).
+ globals.set_globals(UnivGlobals, !IO).
%-----------------------------------------------------------------------------%
Index: compiler/make.program_target.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.program_target.m,v
retrieving revision 1.65
diff -u -r1.65 make.program_target.m
--- compiler/make.program_target.m 8 Jan 2007 03:03:10 -0000 1.65
+++ compiler/make.program_target.m 22 Jan 2007 04:42:19 -0000
@@ -156,10 +156,26 @@
ObjModules, ForeignObjTargetsList, !Info, !IO),
ForeignObjTargets = list.condense(ForeignObjTargetsList),
- foldl2_maybe_stop_at_error(KeepGoing,
- foldl2_maybe_stop_at_error(KeepGoing, make_module_target),
- [IntermediateTargets, ObjTargets, ForeignObjTargets],
- BuildDepsSucceeded, !Info, !IO),
+ foldl2_maybe_stop_at_error(KeepGoing, make_module_target,
+ IntermediateTargets, BuildDepsSucceeded0, !Info, !IO),
+ (
+ BuildDepsSucceeded0 = yes,
+ foldl2_maybe_stop_at_error_maybe_parallel(KeepGoing,
+ make_module_target, ObjTargets,
+ BuildDepsSucceeded1, !Info, !IO)
+ ;
+ BuildDepsSucceeded0 = no,
+ BuildDepsSucceeded1 = no
+ ),
+ (
+ BuildDepsSucceeded1 = yes,
+ foldl2_maybe_stop_at_error(KeepGoing, make_module_target,
+ ForeignObjTargets,
+ BuildDepsSucceeded, !Info, !IO)
+ ;
+ BuildDepsSucceeded1 = no,
+ BuildDepsSucceeded = no
+ ),
linked_target_file_name(MainModuleName, FileType, OutputFileName, !IO),
get_file_timestamp([dir.this_directory], OutputFileName,
Index: compiler/make.util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make.util.m,v
retrieving revision 1.41
diff -u -r1.41 make.util.m
--- compiler/make.util.m 1 Dec 2006 15:04:05 -0000 1.41
+++ compiler/make.util.m 7 Feb 2007 01:20:47 -0000
@@ -53,6 +53,22 @@
%-----------------------------------------------------------------------------%
+ % foldl2_maybe_stop_at_error_maybe_parallel(KeepGoing, P, List, Succeeded,
+ % !Info, !IO).
+ %
+ % Like foldl2_maybe_stop_at_error, but if parallel make is enabled, it
+ % tries to perform a first pass that overlaps execution of P(elem) in
+ % separate threads. Updates to !Info in the first pass are ignored. If
+ % the first pass succeeds, a second sequential pass is made in which
+ % updates !Info are kept. Hence it must be safe to execute P(elem)
+ % concurrently, in any order, and multiple times.
+ %
+:- pred foldl2_maybe_stop_at_error_maybe_parallel(bool::in,
+ foldl2_pred_with_status(T, Info, io)::in(foldl2_pred_with_status),
+ list(T)::in, bool::out, Info::in, Info::out, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
:- type build(T, Info1, Info2) == pred(T, bool, Info1, Info2, io, io).
:- type build(T, Info) == build(T, Info, Info).
:- type build(T) == build(T, make_info).
@@ -280,6 +296,11 @@
:- import_module char.
:- import_module dir.
+:- import_module exception.
+:- import_module thread.
+:- import_module thread.channel.
+
+:- type child_exits == channel(bool).
%-----------------------------------------------------------------------------%
@@ -334,6 +355,99 @@
%-----------------------------------------------------------------------------%
+foldl2_maybe_stop_at_error_maybe_parallel(KeepGoing, MakeTarget, Targets,
+ Success, !Info, !IO) :-
+ globals.io_lookup_int_option(parallel_jobs, ParallelJobs, !IO),
+ (
+ thread.can_spawn,
+ ParallelJobs > 1
+ ->
+ foldl2_maybe_stop_at_error_parallel(KeepGoing, ParallelJobs,
+ MakeTarget, Targets, Success0, !.Info, !IO)
+ ;
+ Success0 = yes
+ ),
+ (
+ Success0 = yes,
+ foldl2_maybe_stop_at_error(KeepGoing, MakeTarget, Targets, Success,
+ !Info, !IO)
+ ;
+ Success0 = no,
+ Success = no
+ ).
+
+:- pred foldl2_maybe_stop_at_error_parallel(bool::in, int::in,
+ foldl2_pred_with_status(T, Info, io)::in(foldl2_pred_with_status),
+ list(T)::in, bool::out, Info::in, io::di, io::uo) is det.
+
+foldl2_maybe_stop_at_error_parallel(KeepGoing, ParallelJobs,
+ MakeTarget, Targets, Success, Info, !IO) :-
+ channel.init(ChildExits, !IO),
+ list.split_upto(ParallelJobs, Targets, InitialTargets, LaterTargets),
+ list.foldl(run_in_child(ChildExits, MakeTarget, Info), InitialTargets,
+ !IO),
+ parent_loop(ChildExits, KeepGoing, MakeTarget, Info,
+ length(Targets), LaterTargets, yes, Success, !IO).
+
+:- pred parent_loop(child_exits::in, bool::in,
+ foldl2_pred_with_status(T, Info, io)::in(foldl2_pred_with_status),
+ Info::in, int::in, list(T)::in, bool::in, bool::out, io::di, io::uo)
+ is det.
+
+parent_loop(ChildExits, KeepGoing, MakeTarget, Info, ChildrenLeft, Targets,
+ !Success, !IO) :-
+ ( ChildrenLeft = 0 ->
+ true
+ ;
+ % Wait for a running child to indicate that it is finished.
+ channel.take(ChildExits, NewSuccess, !IO),
+ (
+ ( NewSuccess = yes
+ ; KeepGoing = yes
+ )
+ ->
+ !:Success = !.Success `and` NewSuccess,
+ (
+ Targets = [],
+ MoreTargets = []
+ ;
+ Targets = [NextTarget | MoreTargets],
+ run_in_child(ChildExits, MakeTarget, Info, NextTarget, !IO)
+ ),
+ parent_loop(ChildExits, KeepGoing, MakeTarget, Info,
+ ChildrenLeft-1, MoreTargets, !Success, !IO)
+ ;
+ !:Success = no
+ )
+ ).
+
+:- pred run_in_child(child_exits::in,
+ foldl2_pred_with_status(T, Info, io)::in(foldl2_pred_with_status),
+ Info::in, T::in, io::di, io::uo) is det.
+
+run_in_child(ChildExits, P, Info, T, !IO) :-
+ promise_equivalent_solutions [!:IO] (
+ spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+ %
+ % Make sure something always gets written to ChildExits when P
+ % finishes, even if terminated by an exception.
+ %
+ try_io((pred(Succ::out, !.IO::di, !:IO::uo) is det :-
+ P(T, Succ, Info, _Info, !IO)
+ ), Result, !IO),
+ (
+ Result = succeeded(Success),
+ channel.put(ChildExits, Success, !IO)
+ ;
+ Result = exception(_),
+ channel.put(ChildExits, no, !IO),
+ rethrow(Result)
+ )
+ ), !IO)
+ ).
+
+%-----------------------------------------------------------------------------%
+
build_with_module_options_and_output_redirect(ModuleName, ExtraOptions,
Build, Succeeded, !Info, !IO) :-
build_with_module_options(ModuleName, ExtraOptions,
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.546
diff -u -r1.546 options.m
--- compiler/options.m 19 Jan 2007 07:04:25 -0000 1.546
+++ compiler/options.m 22 Jan 2007 04:22:36 -0000
@@ -765,6 +765,7 @@
; make
; keep_going
; rebuild
+ ; parallel_jobs
; invoked_by_mmc_make
; extra_init_command
; pre_link_command
@@ -1513,6 +1514,7 @@
make - bool(no),
keep_going - bool(no),
rebuild - bool(no),
+ parallel_jobs - int(1),
invoked_by_mmc_make - bool(no),
pre_link_command - maybe_string(no),
extra_init_command - maybe_string(no),
@@ -2293,6 +2295,7 @@
long_option("make", make).
long_option("keep-going", keep_going).
long_option("rebuild", rebuild).
+long_option("parallel-jobs", parallel_jobs).
long_option("invoked-by-mmc-make", invoked_by_mmc_make).
long_option("pre-link-command", pre_link_command).
long_option("extra-init-command", extra_init_command).
@@ -4662,6 +4665,9 @@
"-k, --keep-going",
"\tWith `--make', keep going as far as",
"\tpossible even if an error is detected.",
+ "--parallel-jobs <n>",
+ "\tWith `--make', attempt to perform up to <n> jobs",
+ "\tconcurrently for some tasks.",
"--pre-link-command <command>",
"\tSpecify a command to run before linking with `mmc --make'.",
"\tThis can be used to compile C source files which rely on",
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.509
diff -u -r1.509 user_guide.texi
--- doc/user_guide.texi 19 Jan 2007 07:05:04 -0000 1.509
+++ doc/user_guide.texi 7 Feb 2007 02:58:10 -0000
@@ -843,7 +843,6 @@
The advantages of the @samp{mmc --make} over Mmake are that there
is no @samp{mmake depend} step and the dependencies are more accurate.
-Parallel builds are not yet supported.
Note that @samp{--use-subdirs} is automatically enabled if you specify
@samp{mmc --make}.
@@ -8432,6 +8431,17 @@
current directory.
@samp{--use-grade-subdirs} does not work with Mmake (it does
work with @samp{mmc --make}).
+
+ at sp 1
+ at item --parallel-jobs <n>
+ at findex --parallel-jobs
+With @samp{--make}, attempt to perform up to @samp{<n>} jobs
+concurrently for some tasks.
+For the option to take effect, the compiler must be built in a parallel
+grade. In low-level C grades the number of threads is also limited by
+the @samp{-P} option in the @samp{MERCURY_OPTIONS} environment variable
+(see @ref{Environment}).
+
@end table
@node Miscellaneous options
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.368
diff -u -r1.368 io.m
--- library/io.m 18 Jan 2007 07:33:03 -0000 1.368
+++ library/io.m 7 Feb 2007 00:45:25 -0000
@@ -22,6 +22,11 @@
% Attempting any operation on a stream which has already been closed results
% in undefined behaviour.
%
+% In multithreaded programs, each thread in the program has its own set of
+% "current" input and output streams. At the time it is created, a child
+% thread inherits the current streams from its parent. Predicates which
+% change which stream is current affect only the calling thread.
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1527,7 +1532,7 @@
% about those streams.
%
:- pred io.get_stream_db(io.stream_db::out, io::di, io::uo) is det.
-:- impure pred io.get_stream_db(io.stream_db::out) is det.
+:- impure pred io.get_stream_db_with_locking(io.stream_db::out) is det.
% Returns the information associated with the specified input
% stream in the given stream database.
@@ -1603,29 +1608,33 @@
extern MR_Word ML_io_stream_db;
extern MR_Word ML_io_user_globals;
- #ifdef MR_THREAD_SAFE
- extern MercuryLock ML_io_user_globals_lock;
- #endif
-
extern int ML_next_stream_id;
#if 0
extern MR_Word ML_io_ops_table;
#endif
+
+ #ifdef MR_THREAD_SAFE
+ extern MercuryLock ML_io_stream_db_lock;
+ extern MercuryLock ML_io_user_globals_lock;
+ extern MercuryLock ML_io_next_stream_id_lock;
+ #endif
").
:- pragma foreign_code("C", "
MR_Word ML_io_stream_db;
MR_Word ML_io_user_globals;
- #ifdef MR_THREAD_SAFE
- MercuryLock ML_io_user_globals_lock;
- #endif
-
/* a counter used to generate unique stream ids */
int ML_next_stream_id;
#if 0
MR_Word ML_io_ops_table;
#endif
+
+ #ifdef MR_THREAD_SAFE
+ MercuryLock ML_io_stream_db_lock;
+ MercuryLock ML_io_user_globals_lock;
+ MercuryLock ML_io_next_stream_id_lock;
+ #endif
").
:- pragma foreign_code("C#", "
@@ -2242,6 +2251,12 @@
[will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
does_not_affect_liveness],
"{
+ /*
+ ** XXX If the Mercury context that called the failing C function is now
+ ** running on a different OS thread, this errno won't be the one
+ ** we are looking for. Or, if a different Mercury context was run on
+ ** the same thread in the meantime, the errno could have been clobbered.
+ */
Error = errno;
MR_update_io(IO0, IO);
}").
@@ -4211,7 +4226,9 @@
io::di, io::uo) is det.
io.stream_info(Stream, MaybeInfo, !IO) :-
+ io.lock_stream_db(!IO),
io.get_stream_db(StreamDb, !IO),
+ io.unlock_stream_db(!IO),
( map.search(StreamDb, get_stream_id(Stream), Info) ->
MaybeInfo = yes(Info)
;
@@ -4276,35 +4293,67 @@
source_name(stdout) = "<standard output>".
source_name(stderr) = "<standard error>".
+ % Caller must NOT hold stream_db lock.
+ %
:- pragma foreign_proc("C",
- io.get_stream_db(StreamDb::out),
- [will_not_call_mercury, tabled_for_io],
+ io.get_stream_db_with_locking(StreamDb::out),
+ [will_not_call_mercury, thread_safe, tabled_for_io],
"
+ MR_LOCK(&ML_io_stream_db_lock, ""io.get_stream_db/1"");
StreamDb = ML_io_stream_db;
+ MR_UNLOCK(&ML_io_stream_db_lock, ""io.get_stream_db/1"");
").
+ % Caller must hold stream_db lock.
+ %
:- pragma foreign_proc("C",
io.get_stream_db(StreamDb::out, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure, tabled_for_io,
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io,
does_not_affect_liveness],
"
StreamDb = ML_io_stream_db;
MR_update_io(IO0, IO);
").
+ % Caller must hold stream_db lock.
+ %
:- pred io.set_stream_db(io.stream_db::in, io::di, io::uo) is det.
:- pragma foreign_proc("C",
io.set_stream_db(StreamDb::in, IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure, tabled_for_io,
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io,
does_not_affect_liveness],
"
ML_io_stream_db = StreamDb;
MR_update_io(IO0, IO);
").
+:- pred io.lock_stream_db(io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ io.lock_stream_db(IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ MR_LOCK(&ML_io_stream_db_lock, MR_PROC_LABEL);
+ IO = IO0;
+").
+
+io.lock_stream_db(!IO).
+
+:- pred io.unlock_stream_db(io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ io.unlock_stream_db(IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
+"
+ MR_UNLOCK(&ML_io_stream_db_lock, MR_PROC_LABEL);
+ IO = IO0;
+").
+
+io.unlock_stream_db(!IO).
+
:- pragma foreign_proc("C#",
- io.get_stream_db(StreamDb::out),
+ io.get_stream_db_with_locking(StreamDb::out),
[will_not_call_mercury, tabled_for_io],
"
StreamDb = ML_io_stream_db;
@@ -4325,7 +4374,7 @@
").
:- pragma foreign_proc("Java",
- io.get_stream_db(StreamDb::out),
+ io.get_stream_db_with_locking(StreamDb::out),
[will_not_call_mercury, tabled_for_io],
"
StreamDb = ML_io_stream_db;
@@ -4351,18 +4400,22 @@
io::di, io::uo) is det.
io.insert_stream_info(Stream, Name, !IO) :-
+ io.lock_stream_db(!IO),
io.get_stream_db(StreamDb0, !IO),
map.set(StreamDb0, get_stream_id(Stream), Name, StreamDb),
- io.set_stream_db(StreamDb, !IO).
+ io.set_stream_db(StreamDb, !IO),
+ io.unlock_stream_db(!IO).
:- pred io.maybe_delete_stream_info(io.stream::in, io::di, io::uo) is det.
io.maybe_delete_stream_info(Stream, !IO) :-
io.may_delete_stream_info(MayDeleteStreamInfo, !IO),
( MayDeleteStreamInfo \= 0 ->
+ io.lock_stream_db(!IO),
io.get_stream_db(StreamDb0, !IO),
map.delete(StreamDb0, get_stream_id(Stream), StreamDb),
- io.set_stream_db(StreamDb, !IO)
+ io.set_stream_db(StreamDb, !IO),
+ io.unlock_stream_db(!IO)
;
true
).
@@ -4642,6 +4695,17 @@
:- pragma foreign_export("IL", io.init_state(di, uo), "ML_io_init_state").
io.init_state(!IO) :-
+ %
+ % In C grades the "current" streams are thread-local values, so can only be
+ % set after the MR_Context has been initialised for the initial thread.
+ %
+ io.set_input_stream(io.stdin_stream, _, !IO),
+ io.set_output_stream(io.stdout_stream, _, !IO),
+ io.stdin_binary_stream(StdinBinary, !IO),
+ io.stdout_binary_stream(StdoutBinary, !IO),
+ io.set_binary_input_stream(StdinBinary, _, !IO),
+ io.set_binary_output_stream(StdoutBinary, _, !IO),
+
io.gc_init(type_of(StreamDb), type_of(Globals), !IO),
map.init(StreamDb),
type_to_univ("<globals>", Globals),
@@ -4792,10 +4856,10 @@
extern MercuryFile mercury_stderr;
extern MercuryFile mercury_stdin_binary;
extern MercuryFile mercury_stdout_binary;
-extern MercuryFile *mercury_current_text_input;
-extern MercuryFile *mercury_current_text_output;
-extern MercuryFile *mercury_current_binary_input;
-extern MercuryFile *mercury_current_binary_output;
+extern MR_Unsigned mercury_current_text_input_index;
+extern MR_Unsigned mercury_current_text_output_index;
+extern MR_Unsigned mercury_current_binary_input_index;
+extern MR_Unsigned mercury_current_binary_output_index;
#define MR_initial_io_state() 0 /* some random number */
#define MR_final_io_state(r) ((void)0)
@@ -4803,6 +4867,11 @@
#define MR_update_io(r_src, r_dest) ((r_dest) = (r_src))
void mercury_init_io(void);
+MercuryFilePtr mercury_current_text_input(void);
+MercuryFilePtr mercury_current_text_output(void);
+MercuryFilePtr mercury_current_binary_input(void);
+MercuryFilePtr mercury_current_binary_output(void);
+int mercury_next_stream_id(void);
MercuryFilePtr mercury_open(const char *filename, const char *openmode);
void mercury_io_error(MercuryFilePtr mf, const char *format, ...);
void mercury_output_error(MercuryFilePtr mf);
@@ -5435,11 +5504,11 @@
MercuryFile mercury_stdin_binary;
MercuryFile mercury_stdout_binary;
-MercuryFilePtr mercury_current_text_input = &mercury_stdin;
-MercuryFilePtr mercury_current_text_output = &mercury_stdout;
-MercuryFilePtr mercury_current_binary_input = &mercury_stdin_binary;
-MercuryFilePtr mercury_current_binary_output = &mercury_stdout_binary;
-
+MR_Unsigned mercury_current_text_input_index;
+MR_Unsigned mercury_current_text_output_index;
+MR_Unsigned mercury_current_binary_input_index;
+MR_Unsigned mercury_current_binary_output_index;
+
void
mercury_init_io(void)
{
@@ -5450,6 +5519,11 @@
MR_mercuryfile_init(NULL, 1, &mercury_stdin_binary);
MR_mercuryfile_init(NULL, 1, &mercury_stdout_binary);
+ mercury_current_text_input_index = MR_new_thread_local_mutable_index();
+ mercury_current_text_output_index = MR_new_thread_local_mutable_index();
+ mercury_current_binary_input_index = MR_new_thread_local_mutable_index();
+ mercury_current_binary_output_index = MR_new_thread_local_mutable_index();
+
#if defined(MR_HAVE_FDOPEN) && (defined(MR_HAVE_FILENO) || defined(fileno)) && \
defined(MR_HAVE_DUP)
MR_file(mercury_stdin_binary) = fdopen(dup(fileno(stdin)), ""rb"");
@@ -5474,10 +5548,57 @@
#endif
#ifdef MR_THREAD_SAFE
+ pthread_mutex_init(&ML_io_stream_db_lock, MR_MUTEX_ATTR);
pthread_mutex_init(&ML_io_user_globals_lock, MR_MUTEX_ATTR);
+ pthread_mutex_init(&ML_io_next_stream_id_lock, MR_MUTEX_ATTR);
#endif
}
+MercuryFilePtr
+mercury_current_text_input(void)
+{
+ MercuryFilePtr stream;
+ MR_get_thread_local_mutable(MercuryFilePtr, stream,
+ mercury_current_text_input_index);
+ return stream;
+}
+
+MercuryFilePtr
+mercury_current_text_output(void)
+{
+ MercuryFilePtr stream;
+ MR_get_thread_local_mutable(MercuryFilePtr, stream,
+ mercury_current_text_output_index);
+ return stream;
+}
+
+MercuryFilePtr
+mercury_current_binary_input(void)
+{
+ MercuryFilePtr stream;
+ MR_get_thread_local_mutable(MercuryFilePtr, stream,
+ mercury_current_binary_input_index);
+ return stream;
+}
+
+MercuryFilePtr
+mercury_current_binary_output(void)
+{
+ MercuryFilePtr stream;
+ MR_get_thread_local_mutable(MercuryFilePtr, stream,
+ mercury_current_binary_output_index);
+ return stream;
+}
+
+int
+mercury_next_stream_id(void)
+{
+ int id;
+ MR_LOCK(&ML_io_next_stream_id_lock, ""io.do_open_text"");
+ id = ML_next_stream_id++;
+ MR_UNLOCK(&ML_io_next_stream_id_lock, ""io.do_open_text"");
+ return id;
+}
").
:- pragma foreign_code("C#", "
@@ -5521,6 +5642,7 @@
mercury_file_init(System.Console.OpenStandardOutput(),
null, System.Console.Out, ML_file_encoding_kind.ML_raw_binary);
+// Note: these are set again in io.init_state.
static MR_MercuryFileStruct mercury_current_text_input =
mercury_stdin;
static MR_MercuryFileStruct mercury_current_text_output =
@@ -5548,6 +5670,7 @@
static MR_MercuryFileStruct mercury_stdout_binary =
new MR_MercuryFileStruct(java.lang.System.out, true);
+// Note: these are set again in io.init_state.
static MR_MercuryFileStruct mercury_current_text_input =
mercury_stdin;
static MR_MercuryFileStruct mercury_current_text_output =
@@ -6282,7 +6405,7 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"
- mercury_print_string(mercury_current_text_output, Message);
+ mercury_print_string(mercury_current_text_output(), Message);
MR_update_io(IO0, IO);
").
@@ -6291,11 +6414,12 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"
- if (MR_PUTCH(*mercury_current_text_output, Character) < 0) {
- mercury_output_error(mercury_current_text_output);
+ MercuryFilePtr out = mercury_current_text_output();
+ if (MR_PUTCH(*out, Character) < 0) {
+ mercury_output_error(out);
}
if (Character == '\\n') {
- MR_line_number(*mercury_current_text_output)++;
+ MR_line_number(*out)++;
}
MR_update_io(IO0, IO);
").
@@ -6305,8 +6429,9 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"
- if (ML_fprintf(mercury_current_text_output, ""%ld"", (long) Val) < 0) {
- mercury_output_error(mercury_current_text_output);
+ MercuryFilePtr out = mercury_current_text_output();
+ if (ML_fprintf(out, ""%ld"", (long) Val) < 0) {
+ mercury_output_error(out);
}
MR_update_io(IO0, IO);
").
@@ -6317,9 +6442,12 @@
does_not_affect_liveness],
"
char buf[MR_SPRINTF_FLOAT_BUF_SIZE];
+ MercuryFilePtr out;
+
MR_sprintf_float(buf, Val);
- if (ML_fprintf(mercury_current_text_output, ""%s"", buf) < 0) {
- mercury_output_error(mercury_current_text_output);
+ out = mercury_current_text_output();
+ if (ML_fprintf(out, ""%s"", buf) < 0) {
+ mercury_output_error(out);
}
MR_update_io(IO0, IO);
").
@@ -6330,10 +6458,10 @@
does_not_affect_liveness],
"
/* call putc with a strictly non-negative byte-sized integer */
- if (MR_PUTCH(*mercury_current_binary_output,
+ if (MR_PUTCH(*mercury_current_binary_output(),
(int) ((unsigned char) Byte)) < 0)
{
- mercury_output_error(mercury_current_text_output);
+ mercury_output_error(mercury_current_text_output());
}
MR_update_io(IO0, IO);
").
@@ -6343,7 +6471,7 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"{
- mercury_print_binary_string(mercury_current_binary_output, Message);
+ mercury_print_binary_string(mercury_current_binary_output(), Message);
MR_update_io(IO0, IO);
}").
@@ -6352,8 +6480,9 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"
- if (MR_FLUSH(*mercury_current_text_output) < 0) {
- mercury_output_error(mercury_current_text_output);
+ MercuryFilePtr out = mercury_current_text_output();
+ if (MR_FLUSH(*out) < 0) {
+ mercury_output_error(out);
}
MR_update_io(IO0, IO);
").
@@ -6363,8 +6492,9 @@
[may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates,
does_not_affect_liveness],
"
- if (MR_FLUSH(*mercury_current_binary_output) < 0) {
- mercury_output_error(mercury_current_binary_output);
+ MercuryFilePtr out = mercury_current_binary_output();
+ if (MR_FLUSH(*out) < 0) {
+ mercury_output_error(out);
}
MR_update_io(IO0, IO);
").
@@ -6971,7 +7101,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- Stream = mercury_current_text_input;
+ Stream = mercury_current_text_input();
MR_update_io(IO0, IO);
").
@@ -6984,7 +7114,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- Stream = mercury_current_text_output;
+ Stream = mercury_current_text_output();
MR_update_io(IO0, IO);
").
@@ -6997,7 +7127,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- Stream = mercury_current_binary_input;
+ Stream = mercury_current_binary_input();
MR_update_io(IO0, IO);
").
@@ -7010,7 +7140,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- Stream = mercury_current_binary_output;
+ Stream = mercury_current_binary_output();
MR_update_io(IO0, IO);
").
@@ -7019,7 +7149,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- LineNum = MR_line_number(*mercury_current_text_input);
+ LineNum = MR_line_number(*mercury_current_text_input());
MR_update_io(IO0, IO);
").
@@ -7042,7 +7172,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- MR_line_number(*mercury_current_text_input) = LineNum;
+ MR_line_number(*mercury_current_text_input()) = LineNum;
MR_update_io(IO0, IO);
").
@@ -7066,7 +7196,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- LineNum = MR_line_number(*mercury_current_text_output);
+ LineNum = MR_line_number(*mercury_current_text_output());
MR_update_io(IO0, IO);
").
@@ -7090,7 +7220,7 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- MR_line_number(*mercury_current_text_output) = LineNum;
+ MR_line_number(*mercury_current_text_output()) = LineNum;
MR_update_io(IO0, IO);
").
@@ -7118,8 +7248,9 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- OutStream = mercury_current_text_input;
- mercury_current_text_input = NewStream;
+ OutStream = mercury_current_text_input();
+ MR_set_thread_local_mutable(MercuryFilePtr, NewStream,
+ mercury_current_text_input_index);
MR_update_io(IO0, IO);
").
@@ -7135,8 +7266,9 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- OutStream = mercury_current_text_output;
- mercury_current_text_output = NewStream;
+ OutStream = mercury_current_text_output();
+ MR_set_thread_local_mutable(MercuryFilePtr, NewStream,
+ mercury_current_text_output_index);
MR_update_io(IO0, IO);
").
@@ -7152,8 +7284,9 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- OutStream = mercury_current_binary_input;
- mercury_current_binary_input = NewStream;
+ OutStream = mercury_current_binary_input();
+ MR_set_thread_local_mutable(MercuryFilePtr, NewStream,
+ mercury_current_binary_input_index);
MR_update_io(IO0, IO);
").
@@ -7169,8 +7302,9 @@
[will_not_call_mercury, promise_pure, tabled_for_io,
does_not_affect_liveness],
"
- OutStream = mercury_current_binary_output;
- mercury_current_binary_output = NewStream;
+ OutStream = mercury_current_binary_output();
+ MR_set_thread_local_mutable(MercuryFilePtr, NewStream,
+ mercury_current_binary_output_index);
MR_update_io(IO0, IO);
").
@@ -7508,8 +7642,13 @@
does_not_affect_liveness],
"
Stream = mercury_open(FileName, Mode);
- ResultCode = (Stream != NULL ? 0 : -1);
- StreamId = (Stream != NULL ? ML_next_stream_id++ : -1);
+ if (Stream != NULL) {
+ ResultCode = 0;
+ StreamId = mercury_next_stream_id();
+ } else {
+ ResultCode = -1;
+ StreamId = -1;
+ }
MR_update_io(IO0, IO);
").
@@ -7520,8 +7659,13 @@
does_not_affect_liveness],
"
Stream = mercury_open(FileName, Mode);
- ResultCode = (Stream != NULL ? 0 : -1);
- StreamId = (Stream != NULL ? ML_next_stream_id++ : -1);
+ if (Stream != NULL) {
+ ResultCode = 0;
+ StreamId = mercury_next_stream_id();
+ } else {
+ ResultCode = -1;
+ StreamId = -1;
+ }
MR_update_io(IO0, IO);
").
@@ -7699,7 +7843,7 @@
:- pragma foreign_proc("C",
io.call_system_code(Command::in, Status::out, Msg::out,
IO0::di, IO::uo),
- [will_not_call_mercury, promise_pure, tabled_for_io,
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
does_not_affect_liveness],
"
Status = system(Command);
Index: library/list.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/list.m,v
retrieving revision 1.162
diff -u -r1.162 list.m
--- library/list.m 18 Jan 2007 07:33:03 -0000 1.162
+++ library/list.m 30 Jan 2007 02:25:57 -0000
@@ -189,7 +189,7 @@
% list.split_list(Len, List, Start, End):
%
% splits `List' into a prefix `Start' of length `Len', and a remainder
- % `End'. See also: list.take, list.drop.
+ % `End'. See also: list.take, list.drop, list.split_upto.
%
:- pred list.split_list(int::in, list(T)::in, list(T)::out, list(T)::out)
is semidet.
@@ -202,6 +202,14 @@
:- pred list.det_split_list(int::in, list(T)::in, list(T)::out, list(T)::out)
is det.
+ % list.split_upto(Len, List, Start, End):
+ %
+ % splits `List' into a prefix `Start' of length `min(Len, length(List))',
+ % and a remainder `End'. See also: list.split_list, list.take, list.drop.
+ %
+:- pred list.split_upto(int::in, list(T)::in, list(T)::out, list(T)::out)
+ is det.
+
% list.take(Len, List, Start):
%
% `Start' is the first `Len' elements of `List'. Fails if `List' has
@@ -1710,6 +1718,18 @@
error("list.det_split_list: index out of range")
).
+list.split_upto(N, List, Start, End) :-
+ (
+ N > 0,
+ List = [Head | List1]
+ ->
+ split_upto(N - 1, List1, Start1, End),
+ Start = [Head | Start1]
+ ;
+ Start = [],
+ End = List
+ ).
+
list.take(N, As, Bs) :-
( N > 0 ->
As = [A | As1],
Index: library/stream.string_writer.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/stream.string_writer.m,v
retrieving revision 1.3
diff -u -r1.3 stream.string_writer.m
--- library/stream.string_writer.m 9 Jan 2007 13:03:38 -0000 1.3
+++ library/stream.string_writer.m 7 Feb 2007 00:46:12 -0000
@@ -360,7 +360,7 @@
; univ_to_type(Univ, C_Pointer) ->
write_c_pointer(Stream, C_Pointer, !State)
;
- impure io.get_stream_db(StreamDB),
+ impure io.get_stream_db_with_locking(StreamDB),
StreamInfo = get_io_stream_info(StreamDB, univ_value(Univ))
->
type_to_univ(StreamInfo, StreamInfoUniv),
Index: library/thread.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/thread.m,v
retrieving revision 1.4
diff -u -r1.4 thread.m
--- library/thread.m 6 Feb 2007 06:47:35 -0000 1.4
+++ library/thread.m 7 Feb 2007 00:15:06 -0000
@@ -30,6 +30,10 @@
%-----------------------------------------------------------------------------%
+ % can_spawn succeeds if spawn/3 is supported in the current grade.
+ %
+:- pred can_spawn 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
@@ -65,6 +69,21 @@
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
+ can_spawn,
+ [will_not_call_mercury, promise_pure],
+"
+#if !defined(MR_HIGHLEVEL_CODE)
+ SUCCESS_INDICATOR = MR_TRUE;
+#else
+ #if defined(MR_THREAD_SAFE)
+ SUCCESS_INDICATOR = MR_TRUE;
+ #else
+ SUCCESS_INDICATOR = MR_FALSE;
+ #endif
+#endif
+").
+
+:- pragma foreign_proc("C",
spawn(Goal::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------
More information about the reviews
mailing list