For review: fork/4
Thomas Charles CONWAY
conway at kryten.cs.mu.OZ.AU
Thu Jun 25 09:40:49 AEST 1998
Hi
Fergus, could you please review these changes?
Thanks,
Thomas
Add a new HO construct to io.m: fork/4 which takes to closures that it
executes concurrently wrt an io__state pair.
Fix several bugs in the runtime engine to do with thread-safe execution.
Add a new flag to pragma c_code/import to allow programmers to specify
whether or not the C code is thread-safe or not, and modify code generation
to put a lock around C code that isn't threadsafe.
boehm_gc/linux_threads.c:
bugfix: remove an errant '*' (dereference).
library/io.m:
add fork/4.
library/math.m:
add a couple of spaces. (cosmetic only)
runtime/mercury_thread.{c,h}:
add a global lock
change the handling of thread creation. create_thread now takes
a "closure" (a C struct with a fn pointer and an argument to pass
the function) which it calls in the new thread. (The same mechanism
is used in the Boehm collector), or NULL which causes the thread
to wait for work to appear in the Mercury runqueue.
runtime/mercury_context.c:
initialize the global lock.
runtime/mercury_engine.{c,h}:
add a new field to the MercuryEngine strucutre which is used to
store a list of saved thread ids. These were being saved in a
local variable in call_engine_inner which was a bug because
call_engine_inner's (C) stack frame gets scribbled on by Mercury
execution. For more detail see the comments in mercury_engine.h
runtime/mercury_wrapper.c:
use the new interface to create_thread.
compiler/prog_io_pragma.m:
parse either a single attribute or a list of attributes instead
of just 'may_call_mercury' in pragma c code and pragma import.
compiler/pragma_c_gen.m:
get the code generator to emit c code to obtain and release the
global lock for pragma c code that isn't threadsafe.
compiler/<various>.m:
change may_call_mercury to list(pragma_c_code_flag).
doc/reference_manual.m:
document the change to pragma c code.
scripts/mgnuc.in:
pass some extra C flags for threadsafe compilation.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
Index: boehm_gc/linux_threads.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/boehm_gc/linux_threads.c,v
retrieving revision 1.2
diff -u -r1.2 linux_threads.c
--- 1.2 1998/06/11 02:40:48
+++ linux_threads.c 1998/06/22 03:48:43
@@ -543,7 +543,7 @@
GC_printf1("pid = %ld\n", (long) getpid());
GC_printf1("sp = 0x%lx\n", (long) &arg);
# endif
- result = (*(si -> start_routine))(si -> arg);
+ result = (si -> start_routine)(si -> arg);
#if DEBUG_THREADS
GC_printf1("Finishing thread 0x%x\n", pthread_self());
#endif
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing bytecode
cvs diff: Diffing bytecode/test
cvs diff: Diffing compiler
Index: compiler/code_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_gen.m,v
retrieving revision 1.52
diff -u -r1.52 code_gen.m
--- 1.52 1998/06/18 06:05:48
+++ code_gen.m 1998/06/24 00:46:55
@@ -888,10 +888,10 @@
{ error("generate_det_goal_2: cannot have det simple_test") }
).
-code_gen__generate_det_goal_2(pragma_c_code(MayCallMercury,
+code_gen__generate_det_goal_2(pragma_c_code(Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- pragma_c_gen__generate_pragma_c_code(model_det, MayCallMercury,
+ pragma_c_gen__generate_pragma_c_code(model_det, Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
PragmaCode, Instr).
@@ -976,10 +976,10 @@
{ error("code_gen__generate_semi_goal_2 - complicated_unify") }
).
-code_gen__generate_semi_goal_2(pragma_c_code(MayCallMercury,
+code_gen__generate_semi_goal_2(pragma_c_code(Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- pragma_c_gen__generate_pragma_c_code(model_semi, MayCallMercury,
+ pragma_c_gen__generate_pragma_c_code(model_semi, Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
PragmaCode, Instr).
@@ -1162,10 +1162,10 @@
code_gen__generate_non_goal_2(unify(_L, _R, _U, _Uni, _C),
_GoalInfo, _Code) -->
{ error("Cannot have a nondet unification.") }.
-code_gen__generate_non_goal_2(pragma_c_code(MayCallMercury,
+code_gen__generate_non_goal_2(pragma_c_code(Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- pragma_c_gen__generate_pragma_c_code(model_non, MayCallMercury,
+ pragma_c_gen__generate_pragma_c_code(model_non, Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
PragmaCode, Instr).
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_goal.m,v
retrieving revision 1.54
diff -u -r1.54 hlds_goal.m
--- 1.54 1998/06/17 05:13:45
+++ hlds_goal.m 1998/06/23 23:13:02
@@ -151,9 +151,9 @@
% C code from a pragma c_code(...) decl.
; pragma_c_code(
- may_call_mercury,
- % Can the C code recursively
- % invoke Mercury code?
+ list(pragma_c_code_flag),
+ % List of attributes of the c code
+ % (ie may_call_mercury, threadsafe)
pred_id, % The called predicate
proc_id, % The mode of the predicate
list(var), % The (Mercury) argument variables
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.55
diff -u -r1.55 intermod.m
--- 1.55 1998/06/09 02:13:03
+++ intermod.m 1998/06/24 02:03:46
@@ -1041,15 +1041,15 @@
X = pragma_c_code(_,_,_,_,_,_,_) - _
)),
Goals, [CCodeGoal]) },
- { CCodeGoal = pragma_c_code(MayCallMercury,
+ { CCodeGoal = pragma_c_code(Attributes,
_, _, Vars, Names, _, PragmaCode) - _ }
;
- { Goal = pragma_c_code(MayCallMercury,
+ { Goal = pragma_c_code(Attributes,
_, _, Vars, Names, _, PragmaCode) - _ }
)
->
intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
- PragmaCode, MayCallMercury, Vars, Varset, Names,
+ PragmaCode, Attributes, Vars, Varset, Names,
SymName)
;
{ error("intermod__write_c_code called with non c_code goal") }
@@ -1058,22 +1058,23 @@
Clauses, Procs).
:- pred intermod__write_c_clauses(proc_table::in, list(proc_id)::in,
- pred_or_func::in, pragma_c_code_impl::in, may_call_mercury::in,
- list(var)::in, varset::in, list(maybe(pair(string, mode)))::in,
- sym_name::in, io__state::di, io__state::uo) is det.
+ pred_or_func::in, pragma_c_code_impl::in,
+ list(pragma_c_code_flag)::in, list(var)::in, varset::in,
+ list(maybe(pair(string, mode)))::in, sym_name::in,
+ io__state::di, io__state::uo) is det.
intermod__write_c_clauses(_, [], _, _, _, _, _, _, _) --> [].
intermod__write_c_clauses(Procs, [ProcId | ProcIds], PredOrFunc,
- PragmaImpl, MayCallMercury, Vars, Varset0, Names, SymName) -->
+ PragmaImpl, Attributes, Vars, Varset0, Names, SymName) -->
{ map__lookup(Procs, ProcId, ProcInfo) },
{ proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes) },
( { MaybeArgModes = yes(ArgModes) } ->
{ get_pragma_c_code_vars(Vars, Names, Varset0, ArgModes,
Varset, PragmaVars) },
- mercury_output_pragma_c_code(MayCallMercury, SymName,
+ mercury_output_pragma_c_code(Attributes, SymName,
PredOrFunc, PragmaVars, Varset, PragmaImpl),
intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
- PragmaImpl, MayCallMercury, Vars, Varset, Names,
+ PragmaImpl, Attributes, Vars, Varset, Names,
SymName)
;
{ error("intermod__write_c_clauses: no mode declaration") }
Index: compiler/live_vars.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/live_vars.m,v
retrieving revision 1.77
diff -u -r1.77 live_vars.m
--- 1.77 1998/06/18 06:06:19
+++ live_vars.m 1998/06/24 01:59:00
@@ -374,7 +374,7 @@
LiveSets = LiveSets0
).
-build_live_sets_in_goal_2(pragma_c_code(MayCallMercury, PredId, ProcId,
+build_live_sets_in_goal_2(pragma_c_code(Attributes, PredId, ProcId,
Args, _, _, _), Liveness, ResumeVars0, LiveSets0,
GoalInfo, ModuleInfo, ProcInfo,
Liveness, ResumeVars, LiveSets) :-
@@ -388,7 +388,7 @@
% won't clobber the registers.
CodeModel \= model_non,
- MayCallMercury = will_not_call_mercury
+ list__member(recursive(will_not_call_mercury), Attributes)
->
ResumeVars = ResumeVars0,
LiveSets = LiveSets0
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.268
diff -u -r1.268 make_hlds.m
--- 1.268 1998/06/21 08:24:02
+++ make_hlds.m 1998/06/24 02:02:15
@@ -506,18 +506,18 @@
add_item_clause(pragma(Pragma), Status, Status, Context,
Module0, Module, Info0, Info) -->
(
- { Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
+ { Pragma = c_code(Attributes, Pred, PredOrFunc, Vars,
VarSet, PragmaImpl) }
->
- module_add_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
+ module_add_pragma_c_code(Attributes, Pred, PredOrFunc,
Vars, VarSet, PragmaImpl, Status, Context,
Module0, Module, Info0, Info)
;
- { Pragma = import(Name, PredOrFunc, Modes, MayCallMercury,
+ { Pragma = import(Name, PredOrFunc, Modes, Attributes,
C_Function) }
->
module_add_pragma_import(Name, PredOrFunc, Modes,
- MayCallMercury, C_Function, Status, Context,
+ Attributes, C_Function, Status, Context,
Module0, Module, Info0, Info)
;
{ Pragma = fact_table(Pred, Arity, File) }
@@ -2086,13 +2086,13 @@
% handling of `pragma export' declarations, in export.m.
:- pred module_add_pragma_import(sym_name, pred_or_func, list(mode),
- may_call_mercury, string, import_status, term__context,
+ list(pragma_c_code_flag), string, import_status, term__context,
module_info, module_info, qual_info, qual_info,
io__state, io__state).
:- mode module_add_pragma_import(in, in, in, in, in, in, in, in, out,
in, out, di, uo) is det.
-module_add_pragma_import(PredName, PredOrFunc, Modes, MayCallMercury,
+module_add_pragma_import(PredName, PredOrFunc, Modes, Attributes,
C_Function, Status, Context, ModuleInfo0, ModuleInfo,
Info0, Info) -->
{ module_info_name(ModuleInfo0, ModuleName) },
@@ -2179,7 +2179,7 @@
ModuleInfo0, ProcId) }
->
pred_add_pragma_import(PredInfo2, PredId, ProcId,
- MayCallMercury, C_Function, Context,
+ Attributes, C_Function, Context,
ModuleInfo0, PredInfo, Info0, Info),
{ map__det_update(Preds0, PredId, PredInfo, Preds) },
{ predicate_table_set_preds(PredicateTable1, Preds,
@@ -2205,12 +2205,12 @@
% This is a subroutine of module_add_pragma_import which adds
% the c_code for a `pragma import' declaration to a pred_info.
-:- pred pred_add_pragma_import(pred_info, pred_id, proc_id, may_call_mercury,
- string, term__context, module_info, pred_info,
- qual_info, qual_info, io__state, io__state).
+:- pred pred_add_pragma_import(pred_info, pred_id, proc_id,
+ list(pragma_c_code_flag), string, term__context, module_info,
+ pred_info, qual_info, qual_info, io__state, io__state).
:- mode pred_add_pragma_import(in, in, in, in, in, in, in, out, in, out,
di, uo) is det.
-pred_add_pragma_import(PredInfo0, PredId, ProcId, MayCallMercury, C_Function,
+pred_add_pragma_import(PredInfo0, PredId, ProcId, Attributes, C_Function,
Context, ModuleInfo, PredInfo, Info0, Info) -->
%
% lookup some information we need from the pred_info and proc_info
@@ -2255,7 +2255,7 @@
% Add the C_Code for this `pragma import' to the clauses_info
%
{ PragmaImpl = ordinary(C_Code, no) },
- clauses_info_add_pragma_c_code(Clauses0, Purity, MayCallMercury,
+ clauses_info_add_pragma_c_code(Clauses0, Purity, Attributes,
PredId, ProcId, VarSet, PragmaVars, ArgTypes, PragmaImpl,
Context, Clauses, Info0, Info),
@@ -2394,14 +2394,14 @@
%-----------------------------------------------------------------------------%
-:- pred module_add_pragma_c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), varset, pragma_c_code_impl, import_status,
- term__context, module_info, module_info, qual_info, qual_info,
- io__state, io__state).
+:- pred module_add_pragma_c_code(list(pragma_c_code_flag), sym_name,
+ pred_or_func, list(pragma_var), varset, pragma_c_code_impl,
+ import_status, term__context, module_info, module_info,
+ qual_info, qual_info, io__state, io__state).
:- mode module_add_pragma_c_code(in, in, in, in, in, in, in, in, in, out,
in, out, di, uo) is det.
-module_add_pragma_c_code(MayCallMercury, PredName, PredOrFunc, PVars, VarSet,
+module_add_pragma_c_code(Attributes, PredName, PredOrFunc, PVars, VarSet,
PragmaImpl, Status, Context, ModuleInfo0, ModuleInfo,
Info0, Info) -->
{ module_info_name(ModuleInfo0, ModuleName) },
@@ -2483,7 +2483,7 @@
{ pred_info_arg_types(PredInfo1, _TVarSet, ArgTypes) },
{ pred_info_get_purity(PredInfo1, Purity) },
clauses_info_add_pragma_c_code(Clauses0, Purity,
- MayCallMercury, PredId, ProcId, VarSet,
+ Attributes, PredId, ProcId, VarSet,
PVars, ArgTypes, PragmaImpl, Context,
Clauses, Info0, Info),
{ pred_info_set_clauses_info(PredInfo1, Clauses,
@@ -3407,14 +3407,14 @@
% pragma c_code declaration and the head vars of the pred. Also return the
% hlds_goal.
-:- pred clauses_info_add_pragma_c_code(clauses_info, purity, may_call_mercury,
- pred_id, proc_id, varset, list(pragma_var), list(type),
- pragma_c_code_impl, term__context, clauses_info,
+:- pred clauses_info_add_pragma_c_code(clauses_info, purity,
+ list(pragma_c_code_flag), pred_id, proc_id, varset, list(pragma_var),
+ list(type), pragma_c_code_impl, term__context, clauses_info,
qual_info, qual_info, io__state, io__state) is det.
:- mode clauses_info_add_pragma_c_code(in, in, in, in, in, in, in, in, in, in,
out, in, out, di, uo) is det.
-clauses_info_add_pragma_c_code(ClausesInfo0, Purity, MayCallMercury, PredId,
+clauses_info_add_pragma_c_code(ClausesInfo0, Purity, Attributes, PredId,
ModeId, PVarSet, PVars, OrigArgTypes, PragmaImpl, Context,
ClausesInfo, Info0, Info) -->
{
@@ -3433,7 +3433,7 @@
goal_info_set_context(GoalInfo0, Context, GoalInfo1),
% Put the purity in the goal_info in case this c code is inlined
add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
- HldsGoal0 = pragma_c_code(MayCallMercury, PredId, ModeId, Args,
+ HldsGoal0 = pragma_c_code(Attributes, PredId, ModeId, Args,
ArgInfo, OrigArgTypes, PragmaImpl) - GoalInfo
},
% Apply unifications with the head args.
@@ -4698,7 +4698,8 @@
ProcInfo, ArgTypes, Module0, C_ProcCode, C_ExtraCode),
% XXX this should be modified to use nondet pragma c_code.
- module_add_pragma_c_code(will_not_call_mercury, SymName, PredOrFunc,
+ { Attributes = [recursive(will_not_call_mercury)] },
+ module_add_pragma_c_code(Attributes, SymName, PredOrFunc,
PragmaVars, VarSet, ordinary(C_ProcCode, no),
Status, Context, Module0, Module1, Info0, Info),
{
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.138
diff -u -r1.138 mercury_to_mercury.m
--- 1.138 1998/06/19 03:16:11
+++ mercury_to_mercury.m 1998/06/24 22:46:01
@@ -67,8 +67,8 @@
io__state, io__state).
:- mode mercury_output_pragma_decl(in, in, in, in, di, uo) is det.
-:- pred mercury_output_pragma_c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), varset, pragma_c_code_impl,
+:- pred mercury_output_pragma_c_code(list(pragma_c_code_flag), sym_name,
+ pred_or_func, list(pragma_var), varset, pragma_c_code_impl,
io__state, io__state).
:- mode mercury_output_pragma_c_code(in, in, in, in, in, in, di, uo) is det.
@@ -296,15 +296,15 @@
{ Pragma = c_code(Code) },
mercury_output_pragma_c_body_code(Code)
;
- { Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
+ { Pragma = c_code(Attributes, Pred, PredOrFunc, Vars,
VarSet, PragmaCode) },
- mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
+ mercury_output_pragma_c_code(Attributes, Pred, PredOrFunc,
Vars, VarSet, PragmaCode)
;
- { Pragma = import(Pred, PredOrFunc, ModeList, MayCallMercury,
+ { Pragma = import(Pred, PredOrFunc, ModeList, Attributes,
C_Function) },
mercury_output_pragma_import(Pred, PredOrFunc, ModeList,
- MayCallMercury, C_Function)
+ Attributes, C_Function)
;
{ Pragma = export(Pred, PredOrFunc, ModeList, C_Function) },
mercury_output_pragma_export(Pred, PredOrFunc, ModeList,
@@ -1925,7 +1925,7 @@
%-----------------------------------------------------------------------------%
% Output the given pragma c_code declaration
-mercury_output_pragma_c_code(MayCallMercury, PredName, PredOrFunc, Vars0,
+mercury_output_pragma_c_code(Attributes, PredName, PredOrFunc, Vars0,
VarSet, PragmaCode) -->
io__write_string(":- pragma c_code("),
mercury_output_sym_name(PredName),
@@ -1953,13 +1953,9 @@
mercury_output_pragma_c_code_vars(ResultVars, VarSet),
io__write_string(")")
),
- (
- { MayCallMercury = may_call_mercury },
- io__write_string(", may_call_mercury, ")
- ;
- { MayCallMercury = will_not_call_mercury },
- io__write_string(", will_not_call_mercury, ")
- ),
+ io__write_string(", "),
+ mercury_output_pragma_c_attributes(Attributes),
+ io__write_string(", "),
(
{ PragmaCode = ordinary(C_Code, _) },
mercury_output_c_code_string(C_Code)
@@ -2050,10 +2046,10 @@
%-----------------------------------------------------------------------------%
:- pred mercury_output_pragma_import(sym_name, pred_or_func, list(mode),
- may_call_mercury, string, io__state, io__state).
+ list(pragma_c_code_flag), string, io__state, io__state).
:- mode mercury_output_pragma_import(in, in, in, in, in, di, uo) is det.
-mercury_output_pragma_import(Name, PredOrFunc, ModeList, MayCallMercury,
+mercury_output_pragma_import(Name, PredOrFunc, ModeList, Attributes,
C_Function) -->
{ varset__init(Varset) }, % the varset isn't really used.
io__write_string(":- pragma import("),
@@ -2071,13 +2067,9 @@
mercury_output_mode_list(ModeList, Varset),
io__write_string(")")
),
- (
- { MayCallMercury = may_call_mercury },
- io__write_string(", may_call_mercury, ")
- ;
- { MayCallMercury = will_not_call_mercury },
- io__write_string(", will_not_call_mercury, ")
- ),
+ io__write_string(", "),
+ mercury_output_pragma_c_attributes(Attributes),
+ io__write_string(", "),
io__write_string(C_Function),
io__write_string(").\n").
@@ -2140,6 +2132,38 @@
{ Indent1 is Indent - 1 },
mercury_output_tabs(Indent1)
).
+
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_output_pragma_c_attributes(list(pragma_c_code_flag),
+ io__state, io__state).
+:- mode mercury_output_pragma_c_attributes(in, di, uo) is det.
+
+mercury_output_pragma_c_attributes(Attributes) -->
+ io__write_string("["),
+ io__write_list(Attributes, ", ", lambda([Attr::in, I0::di, I::uo]
+ is det, (
+ (
+ Attr = recursive(MayCallMercury),
+ (
+ MayCallMercury = may_call_mercury,
+ io__write_string("may_call_mercury", I0, I)
+ ;
+ MayCallMercury = will_not_call_mercury,
+ io__write_string("will_not_call_mercury", I0, I)
+ )
+ ;
+ Attr = threadsafe(ThreadSafe),
+ (
+ ThreadSafe = threadsafe,
+ io__write_string("threadsafe", I0, I)
+ ;
+ ThreadSafe = not_threadsafe,
+ io__write_string("not_threadsafe", I0, I)
+ )
+ )
+ ))),
+ io__write_string("]").
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.36
diff -u -r1.36 module_qual.m
--- 1.36 1998/05/15 07:07:25
+++ module_qual.m 1998/06/24 22:42:28
@@ -668,8 +668,8 @@
qualify_pragma(inline(A, B), inline(A, B), Info, Info) --> [].
qualify_pragma(no_inline(A, B), no_inline(A, B), Info, Info) --> [].
qualify_pragma(obsolete(A, B), obsolete(A, B), Info, Info) --> [].
-qualify_pragma(import(Name, PredOrFunc, Modes0, MayCallMercury, CFunc),
- import(Name, PredOrFunc, Modes, MayCallMercury, CFunc),
+qualify_pragma(import(Name, PredOrFunc, Modes0, Attributes, CFunc),
+ import(Name, PredOrFunc, Modes, Attributes, CFunc),
Info0, Info) -->
qualify_mode_list(Modes0, Modes, Info0, Info).
qualify_pragma(export(Name, PredOrFunc, Modes0, CFunc),
Index: compiler/pd_cost.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pd_cost.m,v
retrieving revision 1.2
diff -u -r1.2 pd_cost.m
--- 1.2 1998/06/09 02:14:15
+++ pd_cost.m 1998/06/24 00:54:46
@@ -99,8 +99,8 @@
goal_info_get_nonlocals(GoalInfo, NonLocals),
pd_cost__unify(NonLocals, Unification, Cost).
-pd_cost__goal(pragma_c_code(MayCallMercury, _, _, Args, _, _, _) - _, Cost) :-
- ( MayCallMercury = will_not_call_mercury ->
+pd_cost__goal(pragma_c_code(Attributes, _, _, Args, _, _, _) - _, Cost) :-
+ ( list__member(recursive(will_not_call_mercury), Attributes) ->
Cost1 = 0
;
pd_cost__stack_flush(Cost1)
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.16
diff -u -r1.16 pragma_c_gen.m
--- 1.16 1998/05/16 07:30:41
+++ pragma_c_gen.m 1998/06/24 06:53:11
@@ -26,7 +26,7 @@
:- import_module list, std_util, term.
:- pred pragma_c_gen__generate_pragma_c_code(code_model::in,
- may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(pragma_c_code_flag)::in, pred_id::in, proc_id::in, list(var)::in,
list(maybe(pair(string, mode)))::in, list(type)::in,
hlds_goal_info::in, pragma_c_code_impl::in, code_tree::out,
code_info::in, code_info::out) is det.
@@ -277,19 +277,19 @@
% and thus we do not have a sure test of whether the code fragments
% invoke the macros.
-pragma_c_gen__generate_pragma_c_code(CodeModel, MayCallMercury,
+pragma_c_gen__generate_pragma_c_code(CodeModel, Attributes,
PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes, _GoalInfo,
PragmaImpl, Code) -->
(
{ PragmaImpl = ordinary(C_Code, Context) },
- pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+ pragma_c_gen__ordinary_pragma_c_code(CodeModel, Attributes,
PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
C_Code, Context, Code)
;
{ PragmaImpl = nondet(
Fields, FieldsContext, First, FirstContext,
Later, LaterContext, Treat, Shared, SharedContext) },
- pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+ pragma_c_gen__nondet_pragma_c_code(CodeModel, Attributes,
PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
Fields, FieldsContext, First, FirstContext,
Later, LaterContext, Treat, Shared, SharedContext,
@@ -299,14 +299,33 @@
%---------------------------------------------------------------------------%
:- pred pragma_c_gen__ordinary_pragma_c_code(code_model::in,
- may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(pragma_c_code_flag)::in, pred_id::in, proc_id::in, list(var)::in,
list(maybe(pair(string, mode)))::in, list(type)::in,
string::in, maybe(term__context)::in, code_tree::out,
code_info::in, code_info::out) is det.
-pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+pragma_c_gen__ordinary_pragma_c_code(CodeModel, Attributes,
PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
C_Code, Context, Code) -->
+
+ %
+ % Extract the attributes
+ %
+ {
+ list__member(recursive(will_not_call_mercury), Attributes)
+ ->
+ MayCallMercury = will_not_call_mercury
+ ;
+ MayCallMercury = may_call_mercury
+ },
+ {
+ list__member(threadsafe(threadsafe), Attributes)
+ ->
+ ThreadSafe = threadsafe
+ ;
+ ThreadSafe = not_threadsafe
+ },
+
%
% First we need to get a list of input and output arguments
%
@@ -373,6 +392,17 @@
},
%
+ % Code fragments to obtain and release the global lock
+ %
+ { ThreadSafe = threadsafe ->
+ ObtainLock = pragma_c_raw_code(""),
+ ReleaseLock = pragma_c_raw_code("")
+ ;
+ ObtainLock = pragma_c_raw_code("\tMR_OBTAIN_GLOBAL_LOCK();\n"),
+ ReleaseLock = pragma_c_raw_code("\tMR_RELEASE_GLOBAL_LOCK();\n")
+ },
+
+ %
% <The C code itself>
%
{ C_Code_Comp = pragma_c_user_code(Context, C_Code) },
@@ -426,8 +456,9 @@
%
% join all the components of the pragma_c together
%
- { Components = [InputComp, SaveRegsComp, C_Code_Comp,
- CheckR1_Comp, RestoreRegsComp, OutputComp] },
+ { Components = [InputComp, SaveRegsComp, ObtainLock, C_Code_Comp,
+ CheckR1_Comp, ReleaseLock, RestoreRegsComp,
+ OutputComp] },
{ PragmaCCode = node([
pragma_c(Decls, Components, MayCallMercury, MaybeFailLabel, no)
- "Pragma C inclusion"
@@ -473,7 +504,7 @@
%---------------------------------------------------------------------------%
:- pred pragma_c_gen__nondet_pragma_c_code(code_model::in,
- may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(pragma_c_code_flag)::in, pred_id::in, proc_id::in, list(var)::in,
list(maybe(pair(string, mode)))::in, list(type)::in,
string::in, maybe(term__context)::in,
string::in, maybe(term__context)::in,
@@ -481,12 +512,22 @@
string::in, maybe(term__context)::in, code_tree::out,
code_info::in, code_info::out) is det.
-pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+pragma_c_gen__nondet_pragma_c_code(CodeModel, Attributes,
PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
_Fields, _FieldsContext, First, FirstContext,
Later, LaterContext, Treat, Shared, SharedContext, Code) -->
{ require(unify(CodeModel, model_non),
"inappropriate code model for nondet pragma C code") },
+ %
+ % Extract the may_call_mercury attribute
+ %
+ {
+ list__member(recursive(will_not_call_mercury), Attributes)
+ ->
+ MayCallMercury = will_not_call_mercury
+ ;
+ MayCallMercury = may_call_mercury
+ },
% First we need to get a list of input and output arguments
code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
{ make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes, ArgInfos, Args) },
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.36
diff -u -r1.36 prog_data.m
--- 1.36 1998/06/09 02:14:23
+++ prog_data.m 1998/06/23 23:23:01
@@ -98,9 +98,11 @@
; c_code(string)
- ; c_code(may_call_mercury, sym_name, pred_or_func,
+ ; c_code(list(pragma_c_code_flag), sym_name, pred_or_func,
list(pragma_var), varset, pragma_c_code_impl)
- % Whether or not the C code may call Mercury,
+ % List of C code attributes:
+ % whether or not the C code may call Mercury,
+ % whether or not hte C code is thread-safe,
% PredName, Predicate or Function, Vars/Mode,
% VarNames, C Code Implementation Info
@@ -119,9 +121,11 @@
% C function name.
; import(sym_name, pred_or_func, list(mode),
- may_call_mercury, string)
+ list(pragma_c_code_flag), string)
% Predname, Predicate/function, Modes,
- % whether or not the C function may call Mercury,
+ % attributes of the C code:
+ % whether or not the C function may call Mercury,
+ % whether it is thread-safe,
% C function name.
; source_file(string)
@@ -282,6 +286,11 @@
:- type instance_interface == list(instance_method).
+:- type pragma_c_code_flag
+ ---> recursive(may_call_mercury)
+ ; threadsafe(threadsafe)
+ .
+
% For pragma c_code, there are two different calling conventions,
% one for C code that may recursively call Mercury code, and another
% more efficient one for the case when we know that the C code will
@@ -289,6 +298,13 @@
:- type may_call_mercury
---> may_call_mercury
; will_not_call_mercury.
+
+ % For pragma c_code, if threadsafe execution is being used, then
+ % we need to put a mutex around the code unless it's declared to
+ % be threadsafe.
+:- type threadsafe
+ ---> not_threadsafe
+ ; threadsafe.
:- type pragma_var
---> pragma_var(var, string, mode).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.14
diff -u -r1.14 prog_io_pragma.m
--- 1.14 1998/05/15 07:07:32
+++ prog_io_pragma.m 1998/06/24 00:55:52
@@ -105,34 +105,34 @@
->
% XXX we should issue a warning; this syntax is deprecated.
% Result = error("pragma c_code doesn't say whether it can call mercury", PredAndVarsTerm)
- MayCallMercury = will_not_call_mercury,
+ % may_call_mercury is a conservative default.
+ Flags = [recursive(may_call_mercury),
+ threadsafe(not_threadsafe)],
(
C_CodeTerm = term__functor(term__string(C_Code), [], Context)
->
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
+ parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm,
ordinary(C_Code, yes(Context)), VarSet, Result)
;
Result = error("invalid `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for C code",
C_CodeTerm)
)
;
- PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm, C_CodeTerm]
+ PragmaTerms = [PredAndVarsTerm, FlagsTerm, C_CodeTerm]
->
(
C_CodeTerm = term__functor(term__string(C_Code), [], Context)
->
- ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
- PredAndVarsTerm, ordinary(C_Code, yes(Context)),
- VarSet, Result)
- ; parse_may_call_mercury(PredAndVarsTerm, MayCallMercury) ->
+ ( parse_pragma_c_code_flags_term(FlagsTerm, Flags) ->
+ parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm,
+ ordinary(C_Code, yes(Context)), VarSet, Result)
+ ; parse_pragma_c_code_flags_term(PredAndVarsTerm, Flags) ->
% XXX we should issue a warning; this syntax is deprecated
- parse_pragma_c_code(ModuleName, MayCallMercury,
- MayCallMercuryTerm, ordinary(C_Code, yes(Context)),
- VarSet, Result)
+ parse_pragma_c_code(ModuleName, Flags, FlagsTerm,
+ ordinary(C_Code, yes(Context)), VarSet, Result)
;
- Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
- MayCallMercuryTerm)
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting a C code attribute or list of attributes'",
+ FlagsTerm)
)
;
Result = error("invalid third argument in `:- pragma c_code' declaration -- expecting string for C code",
@@ -140,23 +140,23 @@
)
;
(
- PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ PragmaTerms = [PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm],
term__context_init(DummyContext),
SharedTerm = term__functor(term__atom("common_code"),
[term__functor(term__string(""), [], DummyContext)],
DummyContext)
;
- PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ PragmaTerms = [PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm]
)
->
- ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
+ ( parse_pragma_c_code_flags_term(FlagsTerm, Flags) ->
( parse_pragma_keyword("local_vars", FieldsTerm, Fields, FieldsContext) ->
( parse_pragma_keyword("first_code", FirstTerm, First, FirstContext) ->
( parse_pragma_keyword("retry_code", LaterTerm, Later, LaterContext) ->
( parse_pragma_keyword("shared_code", SharedTerm, Shared, SharedContext) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
+ parse_pragma_c_code(ModuleName, Flags,
PredAndVarsTerm,
nondet(Fields, yes(FieldsContext),
First, yes(FirstContext),
@@ -164,7 +164,7 @@
share, Shared, yes(SharedContext)),
VarSet, Result)
; parse_pragma_keyword("duplicated_code", SharedTerm, Shared, SharedContext) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
+ parse_pragma_c_code(ModuleName, Flags,
PredAndVarsTerm,
nondet(Fields, yes(FieldsContext),
First, yes(FirstContext),
@@ -172,7 +172,7 @@
duplicate, Shared, yes(SharedContext)),
VarSet, Result)
; parse_pragma_keyword("common_code", SharedTerm, Shared, SharedContext) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
+ parse_pragma_c_code(ModuleName, Flags,
PredAndVarsTerm,
nondet(Fields, yes(FieldsContext),
First, yes(FirstContext),
@@ -196,8 +196,8 @@
FieldsTerm)
)
;
- Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
- MayCallMercuryTerm)
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting pragma c_code attribute or list of attributes'",
+ FlagsTerm)
)
;
Result = error(
@@ -208,7 +208,7 @@
parse_pragma_type(ModuleName, "import", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
(
- PragmaTerms = [PredAndModesTerm, MayCallMercuryTerm,
+ PragmaTerms = [PredAndModesTerm, FlagsTerm,
C_FunctionTerm]
->
(
@@ -230,18 +230,17 @@
->
list__append(ArgModes, [RetMode], Modes),
(
- parse_may_call_mercury(MayCallMercuryTerm,
- MayCallMercury)
+ parse_pragma_c_code_flags_term(FlagsTerm, Flags)
->
Result = ok(pragma(import(FuncName, function,
- Modes, MayCallMercury, C_Function)))
+ Modes, Flags, C_Function)))
;
- Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
- MayCallMercuryTerm)
+ Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
+ FlagsTerm)
)
;
Result = error(
-"expected pragma import(FuncName(ModeList) = Mode, MayCallMercury, C_Function)",
+"expected pragma import(FuncName(ModeList) = Mode, Attributes, C_Function)",
PredAndModesTerm)
)
;
@@ -258,18 +257,17 @@
convert_mode_list(ModeTerms, Modes)
->
(
- parse_may_call_mercury(MayCallMercuryTerm,
- MayCallMercury)
+ parse_pragma_c_code_flags_term(FlagsTerm, Flags)
->
Result = ok(pragma(import(PredName, predicate,
- Modes, MayCallMercury, C_Function)))
+ Modes, Flags, C_Function)))
;
- Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
- MayCallMercuryTerm)
+ Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
+ FlagsTerm)
)
;
Result = error(
-"expected pragma import(PredName(ModeList), MayCallMercury, C_Function)",
+"expected pragma import(PredName(ModeList), Attributes, C_Function)",
PredAndModesTerm)
)
;
@@ -279,13 +277,13 @@
)
;
Result = error(
-"expected pragma import(PredName(ModeList), MayCallMercury, C_Function)",
+"expected pragma import(PredName(ModeList), Attributes, C_Function)",
PredAndModesTerm)
)
;
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
->
- MayCallMercury = may_call_mercury,
+ Flags = [recursive(may_call_mercury), threadsafe(not_threadsafe)],
(
PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
@@ -305,7 +303,7 @@
->
list__append(ArgModes, [RetMode], Modes),
Result = ok(pragma(import(FuncName, function,
- Modes, MayCallMercury, C_Function)))
+ Modes, Flags, C_Function)))
;
Result = error(
"expected pragma import(FuncName(ModeList) = Mode, C_Function)",
@@ -325,7 +323,7 @@
convert_mode_list(ModeTerms, Modes)
->
Result = ok(pragma(import(PredName, predicate,
- Modes, MayCallMercury, C_Function)))
+ Modes, Flags, C_Function)))
;
Result = error(
"expected pragma import(PredName(ModeList), C_Function)",
@@ -679,6 +677,38 @@
Term = term__functor(term__atom(ExpectedKeyword), [Arg], _),
Arg = term__functor(term__string(StringArg), [], StartContext).
+:- pred parse_pragma_c_code_flags_term(term, list(pragma_c_code_flag)).
+:- mode parse_pragma_c_code_flags_term(in, out) is semidet.
+
+parse_pragma_c_code_flags_term(Term, Flags) :-
+ (
+ parse_single_pragma_c_code_flag(Term, Flag)
+ ->
+ Flags = [Flag]
+ ;
+ (
+ Term = term__functor(term__atom("[]"), [], _),
+ Flags = []
+ ;
+ Term = term__functor(term__atom("."), [Hd, Tl], _),
+ Flags = [Flag|Flags0],
+ parse_single_pragma_c_code_flag(Hd, Flag),
+ parse_pragma_c_code_flags_term(Tl, Flags0)
+ )
+ ).
+
+:- pred parse_single_pragma_c_code_flag(term, pragma_c_code_flag).
+:- mode parse_single_pragma_c_code_flag(in, out) is semidet.
+
+parse_single_pragma_c_code_flag(Term, Flag) :-
+ ( parse_may_call_mercury(Term, MayCallMercury) ->
+ Flag = recursive(MayCallMercury)
+ ; parse_threadsafe(Term, ThreadSafe) ->
+ Flag = threadsafe(ThreadSafe)
+ ;
+ fail
+ ).
+
:- pred parse_may_call_mercury(term, may_call_mercury).
:- mode parse_may_call_mercury(in, out) is semidet.
@@ -691,13 +721,21 @@
parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
_), will_not_call_mercury).
+:- pred parse_threadsafe(term, threadsafe).
+:- mode parse_threadsafe(in, out) is semidet.
+
+parse_threadsafe(term__functor(term__atom("threadsafe"), [], _),
+ threadsafe).
+parse_threadsafe(term__functor(term__atom("not_threadsafe"), [], _),
+ not_threadsafe).
+
% parse a pragma c_code declaration
-:- pred parse_pragma_c_code(module_name, may_call_mercury, term,
+:- pred parse_pragma_c_code(module_name, list(pragma_c_code_flag), term,
pragma_c_code_impl, varset, maybe1(item)).
:- mode parse_pragma_c_code(in, in, in, in, in, out) is det.
-parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm0, PragmaImpl,
+parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm0, PragmaImpl,
VarSet, Result) :-
(
PredAndVarsTerm0 = term__functor(Const, Terms0, _)
@@ -732,7 +770,7 @@
parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars, Error),
(
Error = no,
- Result = ok(pragma(c_code(MayCallMercury, PredName,
+ Result = ok(pragma(c_code(Flags, PredName,
PredOrFunc, PragmaVars, VarSet, PragmaImpl)))
;
Error = yes(ErrorMessage),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/table_gen.m,v
retrieving revision 1.1
diff -u -r1.1 table_gen.m
--- 1.1 1998/05/15 07:07:39
+++ table_gen.m 1998/06/24 00:57:05
@@ -654,8 +654,9 @@
TableVarMode = (free -> TableVarInst),
get_table_var_type(TableVarType),
- GoalEx = pragma_c_code(will_not_call_mercury, PredId, ProcId,
- [TableVar], [yes("MC_table_var" - TableVarMode)],
+ GoalEx = pragma_c_code([recursive(will_not_call_mercury)], PredId,
+ ProcId, [TableVar],
+ [yes("MC_table_var" - TableVarMode)],
[TableVarType], ordinary(
" {
static Word MR_table = 0;
@@ -663,8 +664,7 @@
}
",
no)),
-
-
+
set__singleton_set(NonLocals, TableVar),
instmap_delta_from_assoc_list([TableVar - TableVarInst],
InstMapDelta),
cvs diff: Diffing compiler/notes
cvs diff: Diffing doc
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/reference_manual.texi,v
retrieving revision 1.97
diff -u -r1.97 reference_manual.texi
--- 1.97 1998/06/12 07:05:35
+++ reference_manual.texi 1998/06/24 00:05:01
@@ -3186,7 +3186,7 @@
@example
:- pragma c_code(@var{Pred}(@var{Var1}::@var{Mode1}, @var{Var2}::@var{Mode2}, ...),
- may_call_mercury, @var{C_Code}).
+ @var{Attributes}, @var{C_Code}).
@end example
@noindent
@@ -3234,6 +3234,22 @@
This allows the compiler to use a slightly more efficient calling convention.
(If you use this form, and the C code @emph{does} invoke Mercury code,
then the behaviour is undefined --- your program may misbehave or crash.)
+
+In general, you may use either a single attribute or a list of attributes
+in place of @samp{may_call_mercury} or @samp{will_not_call_mercury}.
+In the current release of Mercury there are two attributes:
+ at table @asis
+
+ at item @samp{may_call_mercury}/@samp{will_not_call_mercury} which declares
+whether or not execution inside this C code may call back into Mercury
+or not.
+
+ at item @samp{threadsafe}/@samp{not_threadsafe} which declares whether or not
+it is safe for multiple threads to execute this C code concurrently.
+C code that is not threadsafe has code inserted around it to obtain
+and release a mutex. All non-threadsafe C code shares a single mutex.
+
+ at end table
The C code in a @code{pragma c_code} declaration
for any procedure whose determinism indicates that it could fail
cvs diff: Diffing extras
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/Togl-1.2
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing library
Index: library/io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/io.m,v
retrieving revision 1.156
diff -u -r1.156 io.m
--- 1.156 1998/05/25 07:43:04
+++ io.m 1998/06/24 22:47:37
@@ -947,6 +947,17 @@
% Look up the error message corresponding to a particular error
% code.
+:- pred io__fork(pred(io__state, io__state), pred(io__state, io__state),
+ io__state, io__state).
+:- mode io__fork(pred(di, uo) is cc_multi, pred(di, uo) is cc_multi, di, uo)
+ is cc_multi.
+% io__fork(Pred1, Pred2, State0, State).
+% `State' is the io__state that results from an [arbitary]
+% interleaving of the state modifications made by `Pred1' and
+% `Pred2'. That is, io__fork executes `Pred1' and `Pred2'
+% concurrently (though not necessarily in parallel).
+% This predicate is only available in thread-safe grades.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -3070,6 +3081,140 @@
RetVal = rename(OldFileName, NewFileName);
ML_maybe_make_err_msg(RetVal != 0, ""rename failed: "", RetStr);
update_io(IO0, IO);
+}").
+
+/*---------------------------------------------------------------------------*/
+
+io__fork(This, That) -->
+ make_semaphore(0, Sem),
+ io__fork2(do_then_signal(Sem, This), do_then_signal(Sem, That)),
+ wait_semaphore(Sem),
+ wait_semaphore(Sem).
+
+:- pred io__fork2(pred(io__state, io__state), pred(io__state, io__state),
+ io__state, io__state).
+:- mode io__fork2(pred(di, uo) is cc_multi, pred(di, uo) is cc_multi, di, uo)
+ is cc_multi.
+
+:- pragma no_inline(io__fork2/4).
+
+:- pragma c_code(io__fork2(Pred1::(pred(di, uo) is cc_multi),
+ Pred2::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
+ may_call_mercury, "{
+#ifdef MR_THREAD_SAFE
+ MR_ThreadGoal *child;
+
+ incr_hp_atomic((Word *) child,
+ round_up(sizeof(MR_ThreadGoal), sizeof(Word)));
+
+ child->func = (void (*)(void *)) ML_io_call_forked_goal;
+ child->arg = (void *) Pred2;
+ create_thread(child);
+
+ ML_io_call_forked_goal(Pred1);
+
+ IO = IO0;
+#else
+ fatal_error(""io__fork is not supported in non-threadsafe grades"");
+ IO = IO0;
+#endif
+}").
+
+:- pred do_then_signal(semaphore, pred(io__state, io__state),
+ io__state, io__state).
+:- mode do_then_signal(in, pred(di, uo) is cc_multi, di, uo) is cc_multi.
+
+do_then_signal(Sem, Pred) -->
+ call(Pred),
+ signal_semaphore(Sem).
+
+:- pred io__call_cc_multi_closure(pred(io__state, io__state),
+ io__state, io__state).
+:- mode io__call_cc_multi_closure(pred(di, uo) is cc_multi, di, uo) is cc_multi.
+
+:- pragma export(io__call_cc_multi_closure(pred(di, uo) is cc_multi, di, uo),
+ "ML_io_call_forked_goal").
+
+io__call_cc_multi_closure(Pred) -->
+ call(Pred).
+
+:- pragma c_header_code("
+#ifdef MR_THREAD_SAFE
+ typedef struct {
+ MercuryLock lock;
+ MercuryCond cond;
+ int count;
+ } ML_Semaphore;
+#endif
+").
+
+:- type semaphore == c_pointer.
+
+:- pred make_semaphore(int, semaphore, io__state, io__state).
+:- mode make_semaphore(in, out, di, uo) is det.
+
+:- pragma no_inline(make_semaphore/4).
+
+:- pragma c_code(make_semaphore(N::in, Sem::out, IO0::di, IO::uo), "{
+#ifdef MR_THREAD_SAFE
+ ML_Semaphore *sem;
+ incr_hp_atomic((Word *) sem,
+ round_up(sizeof(ML_Semaphore), sizeof(Word)));
+ pthread_mutex_init(&(sem->lock), MR_MUTEX_ATTR);
+ pthread_cond_init(&(sem->cond), MR_COND_ATTR);
+ sem->count = N;
+ Sem = (Word) sem;
+ IO = IO0;
+#else
+ fatal_error(""semaphores are not supported in non-threadsafe grades"");
+ IO = IO0;
+#endif
+}").
+
+:- pragma no_inline(signal_semaphore/3).
+
+:- pred signal_semaphore(semaphore, io__state, io__state).
+:- mode signal_semaphore(in, di, uo) is det.
+
+:- pragma c_code(signal_semaphore(Sem::in, IO0::di, IO::uo), "{
+#ifdef MR_THREAD_SAFE
+ ML_Semaphore *sem;
+ sem = (ML_Semaphore *) Sem;
+ MR_LOCK(&(sem->lock), ""io__signal_semaphore"");
+ sem->count++;
+ MR_SIGNAL(&(sem->cond));
+ MR_UNLOCK(&(sem->lock), ""io__signal_semaphore"");
+ IO = IO0;
+#else
+ fatal_error(""semaphores are not supported in non-threadsafe grades"");
+ IO = IO0;
+#endif
+}").
+
+:- pragma no_inline(wait_semaphore/3).
+
+:- pred wait_semaphore(semaphore, io__state, io__state).
+:- mode wait_semaphore(in, di, uo) is det.
+
+:- pragma c_code(wait_semaphore(Sem::in, IO0::di, IO::uo), "{
+#ifdef MR_THREAD_SAFE
+ ML_Semaphore *sem;
+ sem = (ML_Semaphore *) Sem;
+
+ MR_LOCK(&(sem->lock), ""io__wait_semaphore"");
+ while (1) {
+ if (sem->count > 0)
+ break;
+ MR_WAIT(&(sem->cond), &(sem->lock));
+ }
+ sem->count--;
+ MR_UNLOCK(&(sem->lock), ""io__signal_semaphore"");
+
+ IO = IO0;
+#else
+ fatal_error(""semaphores are not supported in non-threadsafe grades"");
+ IO = IO0;
+#endif
}").
/*---------------------------------------------------------------------------*/
Index: library/math.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/math.m,v
retrieving revision 1.12
diff -u -r1.12 math.m
--- 1.12 1998/05/31 22:19:09
+++ math.m 1998/06/24 07:03:47
@@ -186,7 +186,7 @@
"). % end pragma c_header_code
-:- pragma(c_code, "
+:- pragma c_code("
#include <stdio.h>
@@ -209,12 +209,12 @@
% Mathematical constants from math.m
%
% Pythagoras' number
-:- pragma c_code(math__pi = (Pi::out),will_not_call_mercury,"
+:- pragma c_code(math__pi = (Pi::out), will_not_call_mercury,"
Pi = MERCURY_FLOAT__PI;
").
% Base of natural logarithms
-:- pragma c_code(math__e = (E::out),will_not_call_mercury,"
+:- pragma c_code(math__e = (E::out), will_not_call_mercury,"
E = MERCURY_FLOAT__E;
").
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing runtime
Index: runtime/mercury_context.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_context.c,v
retrieving revision 1.5
diff -u -r1.5 mercury_context.c
--- 1.5 1998/06/15 07:00:03
+++ mercury_context.c 1998/06/24 06:41:21
@@ -48,6 +48,8 @@
free_context_list_lock = make(MercuryLock);
pthread_mutex_init(free_context_list_lock, MR_MUTEX_ATTR);
+ pthread_mutex_init(&MR_global_lock, MR_MUTEX_ATTR);
+
MR_KEY_CREATE(&MR_engine_base_key, NULL);
#endif
Index: runtime/mercury_engine.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_engine.c,v
retrieving revision 1.9
diff -u -r1.9 mercury_engine.c
--- 1.9 1998/06/18 04:30:42
+++ mercury_engine.c 1998/06/24 22:58:29
@@ -105,6 +105,7 @@
#ifdef MR_THREAD_SAFE
eng->owner_thread = pthread_self();
eng->c_depth = 0;
+ eng->saved_owners = NULL;
#endif
/*
@@ -221,9 +222,6 @@
void
call_engine_inner(Code *entry_point)
{
-#ifdef MR_THREAD_SAFE
- MercuryThread saved_owner_thread;
-#endif
/*
** Allocate some space for local variables in other
** procedures. This is done because we may jump into the middle
@@ -284,7 +282,15 @@
*/
#ifdef MR_THREAD_SAFE
MR_ENGINE(c_depth)++;
- saved_owner_thread = MR_ENGINE(this_context)->owner_thread;
+{
+ MercuryThreadList *new_element;
+
+ new_element = make(MercuryThreadList);
+ new_element->thread = MR_ENGINE(this_context)->owner_thread;
+ new_element->next = MR_ENGINE(saved_owners);
+ MR_ENGINE(saved_owners) = new_element;
+}
+
MR_ENGINE(this_context)->owner_thread = MR_ENGINE(owner_thread);
#endif
@@ -295,16 +301,32 @@
noprof_call(entry_point, LABEL(engine_done));
Define_label(engine_done);
+
/*
** Decrement the number of times we've entered this
** engine from C and restore the owning thread in
** the current context.
*/
#ifdef MR_THREAD_SAFE
+
assert(MR_ENGINE(this_context)->owner_thread
== MR_ENGINE(owner_thread));
MR_ENGINE(c_depth)--;
- MR_ENGINE(this_context)->owner_thread = saved_owner_thread;
+{
+ MercuryThreadList *tmp;
+ MercuryThread val;
+
+ tmp = MR_ENGINE(saved_owners);
+ if (tmp != NULL)
+ {
+ val = tmp->thread;
+ MR_ENGINE(saved_owners) = tmp->next;
+ free(tmp);
+ } else {
+ val = 0;
+ }
+ MR_ENGINE(this_context)->owner_thread = val;
+}
#endif
/*
Index: runtime/mercury_engine.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_engine.h,v
retrieving revision 1.6
diff -u -r1.6 mercury_engine.h
--- 1.6 1998/06/18 04:30:43
+++ mercury_engine.h 1998/06/24 22:57:53
@@ -151,6 +151,11 @@
/*---------------------------------------------------------------------------*/
+typedef struct MR_mercury_thread_list_struct {
+ MercuryThread thread;
+ struct MR_mercury_thread_list_struct *next;
+} MercuryThreadList;
+
/*
** The Mercury engine structure.
** Normally there is one of these for each Posix thread.
@@ -180,8 +185,9 @@
#ifdef MR_THREAD_SAFE
MercuryThread owner_thread;
unsigned c_depth;
+ MercuryThreadList *saved_owners;
/*
- ** These two fields are used to ensure that when a
+ ** These three fields are used to ensure that when a
** thread executing C code calls the Mercury engine
** associated with that thread, the Mercury code
** will finish in the same engine and return appropriately.
@@ -193,6 +199,10 @@
** the Mercury engine finishes, c_depth is decremented and
** the owner_thread field of the current context is restored
** to its previous value.
+ ** The list `saved_owners' is used in call_engine_inner
+ ** to store the owner of a context across calls into Mercury.
+ ** At the moment this is only used for sanity checking - that
+ ** execution never returns into C in the wrong thread.
*/
#endif
jmp_buf *e_jmp_buf;
Index: runtime/mercury_thread.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_thread.c,v
retrieving revision 1.2
diff -u -r1.2 mercury_thread.c
--- 1.2 1998/06/15 07:00:15
+++ mercury_thread.c 1998/06/24 06:39:28
@@ -19,17 +19,20 @@
#ifdef MR_THREAD_SAFE
MercuryThreadKey MR_engine_base_key;
+ MercuryLock MR_global_lock;
#endif
bool MR_exit_now;
-void *init_thread(void *unused);
-
Declare_entry(do_runnext);
#ifdef MR_THREAD_SAFE
+
+void *
+create_thread_2(void *goal);
+
MercuryThread *
-create_thread(int x)
+create_thread(MR_ThreadGoal *goal)
{
MercuryThread *thread;
pthread_attr_t attrs;
@@ -37,7 +40,7 @@
thread = make(MercuryThread);
pthread_attr_init(&attrs);
- err = pthread_create(thread, &attrs, init_thread, (void *) x);
+ err = pthread_create(thread, &attrs, create_thread_2, (void *) goal);
#if 0
fprintf(stderr, "pthread_create returned %d (errno = %d)\n",
@@ -49,10 +52,28 @@
return thread;
}
-#endif /* MR_THREAD_SAFE */
void *
-init_thread(void *unused)
+create_thread_2(void *goal0)
+{
+ MR_ThreadGoal *goal;
+
+ goal = (MR_ThreadGoal *) goal0;
+ if (goal != NULL)
+ {
+ init_thread(MR_use_now);
+ (goal->func)(goal->arg);
+ } else {
+ init_thread(MR_use_later);
+ }
+
+ return NULL;
+}
+
+#endif /* MR_THREAD_SAFE */
+
+void
+init_thread(MR_when_to_use when_to_use)
{
MercuryEngine *eng;
@@ -85,13 +106,20 @@
MR_ENGINE(owner_thread) = pthread_self();
#endif
- if (unused == 0) {
- call_engine(ENTRY(do_runnext));
-
- destroy_engine(eng);
+ switch (when_to_use) {
+ case MR_use_later :
+ call_engine(ENTRY(do_runnext));
+
+ destroy_engine(eng);
+ return;
+
+ case MR_use_now :
+ return;
+
+ default:
+ fatal_error("init_thread was passed a bad value");
+ return;
}
-
- return NULL;
}
#ifdef MR_THREAD_SAFE
@@ -154,6 +182,11 @@
assert(err == 0);
}
#endif
+
+/*
+INIT mercury_scheduler_wrapper
+ENDINIT
+*/
Define_extern_entry(do_runnext);
Index: runtime/mercury_thread.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_thread.h,v
retrieving revision 1.2
diff -u -r1.2 mercury_thread.h
--- 1.2 1998/06/15 07:00:16
+++ mercury_thread.h 1998/06/24 22:54:34
@@ -52,6 +52,12 @@
#define MR_WAIT(cnd, mtx) MR_cond_wait((cnd), (mtx))
#endif
+ #define MR_OBTAIN_GLOBAL_C_LOCK() MR_mutex_lock(&MR_global_lock, \
+ "pragma c code");
+
+ #define MR_RELEASE_GLOBAL_C_LOCK() MR_mutex_unlock(&MR_global_lock, \
+ "pragma c code");
+
#if defined(MR_DIGITAL_UNIX_PTHREADS)
#define MR_GETSPECIFIC(key) ({ \
pthread_addr_t gstmp; \
@@ -64,10 +70,26 @@
#define MR_KEY_CREATE pthread_key_create
#endif
- MercuryThread *create_thread(int x);
+ typedef struct {
+ void (*func)(void *);
+ void *arg;
+ } MR_ThreadGoal;
+ MercuryThread *create_thread(MR_ThreadGoal *);
void destroy_thread(void *eng);
extern bool MR_exit_now;
+ /*
+ ** MR_global_lock is a mutex for ensuring that only one non-threadsafe
+ ** piece of pragma c code executes at a time. If `not_threadsafe' is
+ ** given or `threadsafe' is not given in the attributes of a pragma
+ ** c code definition of a predicate, then the generated code will
+ ** obtain this lock before executing, then release it.
+ ** XXX we should emit a warning if may_call_mercury and not_threadsafe
+ ** (the defaults) are specified since if you obtain the lock then
+ ** call back into Mercury deadlock could result.
+ */
+ extern MercuryLock MR_global_lock;
+
#else /* not MR_THREAD_SAFE */
#define MR_LOCK(nothing, from) do { } while (0)
@@ -76,8 +98,23 @@
#define MR_SIGNAL(nothing) do { } while (0)
#define MR_WAIT(no, thing) do { } while (0)
+ #define MR_OBTAIN_GLOBAL_C_LOCK() do { } while (0)
+
+ #define MR_RELEASE_GLOBAL_C_LOCK() do { } while (0)
+
#endif
-void *init_thread(void *);
+/*
+** The following enum is used as the argument to init_thread.
+** MR_use_now should be passed to init_thread to indicate that
+** it has been called in a context in which it should initialize
+** the current thread's environment and return.
+** MR_use_later should be passed to indicate that the thread should
+** be initialized, then suspend waiting for work to appear in the
+** runqueue.
+*/
+typedef enum { MR_use_now, MR_use_later } MR_when_to_use;
+
+void init_thread(MR_when_to_use);
#endif
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.14
diff -u -r1.14 mercury_wrapper.c
--- 1.14 1998/06/18 04:30:47
+++ mercury_wrapper.c 1998/06/23 08:00:17
@@ -156,6 +156,7 @@
#endif
Declare_entry(do_interpreter);
+Declare_entry(do_runnext);
/*---------------------------------------------------------------------------*/
@@ -248,15 +249,15 @@
/* start up the Mercury engine */
#ifndef MR_THREAD_SAFE
- init_thread((void *) 1);
+ init_thread(MR_use_now);
#else
{
int i;
init_thread_stuff();
- init_thread((void *)1);
+ init_thread(MR_use_now);
MR_exit_now = FALSE;
for (i = 1 ; i < MR_num_threads ; i++)
- create_thread(0);
+ create_thread(NULL);
}
#endif
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing scripts
Index: scripts/mgnuc.in
===================================================================
RCS file: /home/staff/zs/imp/mercury/scripts/mgnuc.in,v
retrieving revision 1.51
diff -u -r1.51 mgnuc.in
--- 1.51 1998/06/11 02:42:47
+++ mgnuc.in 1998/06/22 03:48:45
@@ -265,7 +265,8 @@
*solaris*) THREAD_OPTS="-DMR_THREAD_SAFE -DSOLARIS_THREADS \
-D_SOLARIS_PTHREADS -D_REENTRANT";;
- *linux*) THREAD_OPTS="-DMR_THREAD_SAFE -DLINUX_THREADS";;
+ *linux*) THREAD_OPTS="-DMR_THREAD_SAFE -DLINUX_THREADS \
+ -D_THREAD_SAFE -D_REENTRANT";;
*) THREAD_OPTS="" ;;
esac ;;
cvs diff: Diffing tools
cvs diff: Diffing trial
cvs diff: Diffing util
--
Thomas Conway <conway at cs.mu.oz.au>
Nail here [] for new monitor. )O+
More information about the developers
mailing list