Changes to pragma c & runtime fixes
Thomas Charles CONWAY
conway at cs.mu.OZ.AU
Thu Aug 6 11:52:56 AEST 1998
Hi
Most of these changes came up for review in my io__fork diff. I've
addressed the comments that Fergus made then. The io__fork predicate
(and directly related changes) have gone (for the time being).
So here is the revised diff. Fergus?
--
Thomas Conway <conway at cs.mu.oz.au>
Nail here [] for new monitor. )O+
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 thread_safe.
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 structre 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.
These are stored in an abstract type 'pragma_c_code_attributes'
that uses a bit array (aka int) to store the attributes.
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 thread_safe.
compiler/<various>.m:
Change may_call_mercury to pragma_c_code_attributes.
doc/reference_manual.m:
Document the change to pragma c code.
scripts/mgnuc.in:
Pass some extra C flags for thread-safe compilation for Linux.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
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 browser
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.54
diff -u -r1.54 code_gen.m
--- code_gen.m 1998/07/20 10:00:21 1.54
+++ code_gen.m 1998/08/03 04:33:29
@@ -805,12 +805,12 @@
call_gen__generate_builtin(CodeModel, PredId, ProcId, Args,
Code)
).
-code_gen__generate_goal_2(pragma_c_code(MayCallMercury, PredId, ProcId,
- Args, ArgNames, OrigArgTypes, PragmaImpl),
- GoalInfo, CodeModel, Code) -->
- pragma_c_gen__generate_pragma_c_code(CodeModel, MayCallMercury,
- PredId, ProcId, Args, ArgNames, OrigArgTypes, GoalInfo,
- PragmaImpl, Code).
+code_gen__generate_goal_2(pragma_c_code(Attributes,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
+ GoalInfo, CodeModel, Instr) -->
+ pragma_c_gen__generate_pragma_c_code(CodeModel, 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.55
diff -u -r1.55 hlds_goal.m
--- hlds_goal.m 1998/07/08 20:56:14 1.55
+++ hlds_goal.m 1998/08/04 02:42:12
@@ -151,9 +151,7 @@
% C code from a pragma c_code(...) decl.
; pragma_c_code(
- may_call_mercury,
- % Can the C code recursively
- % invoke Mercury code?
+ pragma_c_code_attributes,
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.58
diff -u -r1.58 intermod.m
--- intermod.m 1998/07/14 06:24:14 1.58
+++ intermod.m 1998/08/04 02:46:06
@@ -1043,15 +1043,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") }
@@ -1060,22 +1060,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,
+ pragma_c_code_attributes::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
--- live_vars.m 1998/06/18 06:06:19 1.77
+++ live_vars.m 1998/08/04 04:02:26
@@ -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
+ may_call_mercury(Attributes, will_not_call_mercury)
->
ResumeVars = ResumeVars0,
LiveSets = LiveSets0
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.270
diff -u -r1.270 make_hlds.m
--- make_hlds.m 1998/08/04 02:13:56 1.270
+++ make_hlds.m 1998/08/04 05:39:34
@@ -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) }
@@ -2107,13 +2107,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,
+ pragma_c_code_attributes, 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) },
@@ -2200,7 +2200,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,
@@ -2226,12 +2226,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,
+ pragma_c_code_attributes, 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
@@ -2276,7 +2276,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),
@@ -2415,14 +2415,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(pragma_c_code_attributes, 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) },
@@ -2504,7 +2504,7 @@
{ pred_info_arg_types(PredInfo1, 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,
@@ -3428,14 +3428,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,
+ pragma_c_code_attributes, 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) -->
{
@@ -3454,7 +3454,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.
@@ -4719,7 +4719,9 @@
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,
+ { default_attributes(Attrs0) },
+ { set_may_call_mercury(Attrs0, will_not_call_mercury, Attrs) },
+ module_add_pragma_c_code(Attrs, 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.141
diff -u -r1.141 mercury_to_mercury.m
--- mercury_to_mercury.m 1998/08/04 12:16:28 1.141
+++ mercury_to_mercury.m 1998/08/05 01:24:30
@@ -68,8 +68,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(pragma_c_code_attributes, 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.
@@ -301,15 +301,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,
@@ -1990,7 +1990,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),
@@ -2018,13 +2018,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)
@@ -2115,10 +2111,10 @@
%-----------------------------------------------------------------------------%
:- pred mercury_output_pragma_import(sym_name, pred_or_func, list(mode),
- may_call_mercury, string, io__state, io__state).
+ pragma_c_code_attributes, 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("),
@@ -2136,13 +2132,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").
@@ -2205,6 +2197,32 @@
{ Indent1 is Indent - 1 },
mercury_output_tabs(Indent1)
).
+
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_output_pragma_c_attributes(pragma_c_code_attributes,
+ io__state, io__state).
+:- mode mercury_output_pragma_c_attributes(in, di, uo) is det.
+
+mercury_output_pragma_c_attributes(Attributes) -->
+ io__write_string("["),
+ { may_call_mercury(Attributes, MayCallMercury) },
+ (
+ { MayCallMercury = may_call_mercury },
+ io__write_string("may_call_mercury, ")
+ ;
+ { MayCallMercury = will_not_call_mercury },
+ io__write_string("will_not_call_mercury, ")
+ ),
+ { thread_safe(Attributes, ThreadSafe) },
+ (
+ { ThreadSafe = not_thread_safe },
+ io__write_string("not_thread_safe")
+ ;
+ { ThreadSafe = thread_safe },
+ io__write_string("thread_safe")
+ ),
+ io__write_string("]").
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.38
diff -u -r1.38 module_qual.m
--- module_qual.m 1998/08/04 06:44:18 1.38
+++ module_qual.m 1998/08/04 22:25:09
@@ -672,8 +672,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
--- pd_cost.m 1998/06/09 02:14:15 1.2
+++ pd_cost.m 1998/08/04 04:33:29
@@ -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) :-
+ ( may_call_mercury(Attributes, will_not_call_mercury) ->
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.17
diff -u -r1.17 pragma_c_gen.m
--- pragma_c_gen.m 1998/07/29 08:53:40 1.17
+++ pragma_c_gen.m 1998/08/04 02:47:58
@@ -26,8 +26,8 @@
:- 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(maybe(pair(string, mode)))::in, list(type)::in,
+ pragma_c_code_attributes::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,15 +299,22 @@
%---------------------------------------------------------------------------%
:- 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(maybe(pair(string, mode)))::in, list(type)::in,
+ pragma_c_code_attributes::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
+ %
+ { may_call_mercury(Attributes, MayCallMercury) },
+ { thread_safe(Attributes, ThreadSafe) },
+
+ %
% First we need to get a list of input and output arguments
%
code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
@@ -373,6 +380,17 @@
},
%
+ % Code fragments to obtain and release the global lock
+ %
+ { ThreadSafe = thread_safe ->
+ 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 +444,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,20 +492,24 @@
%---------------------------------------------------------------------------%
:- 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(maybe(pair(string, mode)))::in, list(type)::in,
+ pragma_c_code_attributes::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,
string::in, maybe(term__context)::in, pragma_shared_code_treatment::in,
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
+ %
+ { may_call_mercury(Attributes, MayCallMercury) },
% 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.38
diff -u -r1.38 prog_data.m
--- prog_data.m 1998/08/04 06:44:24 1.38
+++ prog_data.m 1998/08/06 00:19:10
@@ -102,9 +102,11 @@
; c_code(string)
- ; c_code(may_call_mercury, sym_name, pred_or_func,
+ ; c_code(pragma_c_code_attributes, sym_name, pred_or_func,
list(pragma_var), varset, pragma_c_code_impl)
- % Whether or not the C code may call Mercury,
+ % Set of C code attributes, eg.:
+ % whether or not the C code may call Mercury,
+ % whether or not the C code is thread-safe
% PredName, Predicate or Function, Vars/Mode,
% VarNames, C Code Implementation Info
@@ -123,9 +125,11 @@
% C function name.
; import(sym_name, pred_or_func, list(mode),
- may_call_mercury, string)
+ pragma_c_code_attributes, string)
% Predname, Predicate/function, Modes,
- % whether or not the C function may call Mercury,
+ % Set of C code attributes, eg.:
+ % whether or not the C code may call Mercury,
+ % whether or not the C code is thread-safe
% C function name.
; source_file(string)
@@ -297,6 +301,27 @@
:- type instance_interface == list(instance_method).
+ % an abstract type for representing a set of
+ % `pragma_c_code_attribute's.
+:- type pragma_c_code_attributes.
+
+:- pred default_attributes(pragma_c_code_attributes).
+:- mode default_attributes(out) is det.
+
+:- pred may_call_mercury(pragma_c_code_attributes, may_call_mercury).
+:- mode may_call_mercury(in, out) is det.
+
+:- pred set_may_call_mercury(pragma_c_code_attributes, may_call_mercury,
+ pragma_c_code_attributes).
+:- mode set_may_call_mercury(in, in, out) is det.
+
+:- pred thread_safe(pragma_c_code_attributes, thread_safe).
+:- mode thread_safe(in, out) is det.
+
+:- pred set_thread_safe(pragma_c_code_attributes, thread_safe,
+ pragma_c_code_attributes).
+:- mode set_thread_safe(in, in, out) is det.
+
% 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
@@ -305,6 +330,13 @@
---> may_call_mercury
; will_not_call_mercury.
+ % If thread_safe execution is enabled, then we need to put a mutex
+ % around the C code for each `pragma c_code' declaration, unless
+ % it's declared to be thread_safe.
+:- type thread_safe
+ ---> not_thread_safe
+ ; thread_safe.
+
:- type pragma_var
---> pragma_var(var, string, mode).
% variable, name, mode
@@ -598,3 +630,39 @@
; may_be_unqualified.
%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+
+:- type pragma_c_code_attributes == int.
+
+default_attributes(0).
+
+% bit 1 : may_call_mercury / will_not_call_mercury
+% bit 2 : not_thread_safe / thread_safe
+
+may_call_mercury(Attrs, MayCallMercury) :-
+ ( Attrs /\ 0x01 \= 0 ->
+ MayCallMercury = will_not_call_mercury
+ ;
+ MayCallMercury = may_call_mercury
+ ).
+
+thread_safe(Attrs, ThreadSafe) :-
+ ( Attrs /\ 0x02 \= 0 ->
+ ThreadSafe = thread_safe
+ ;
+ ThreadSafe = not_thread_safe
+ ).
+
+set_may_call_mercury(Attrs0, may_call_mercury, Attrs) :-
+ Attrs = Attrs0 /\ (\ 0x01).
+set_may_call_mercury(Attrs0, will_not_call_mercury, Attrs) :-
+ Attrs = Attrs0 \/ 0x01.
+
+set_thread_safe(Attrs0, not_thread_safe, Attrs) :-
+ Attrs = Attrs0 /\ (\ 0x02).
+set_thread_safe(Attrs0, thread_safe, Attrs) :-
+ Attrs = Attrs0 \/ 0x02.
+
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
--- prog_io_pragma.m 1998/05/15 07:07:32 1.14
+++ prog_io_pragma.m 1998/08/04 02:40:55
@@ -105,34 +105,33 @@
->
% 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.
+ default_attributes(Attributes),
(
C_CodeTerm = term__functor(term__string(C_Code), [], Context)
->
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
+ parse_pragma_c_code(ModuleName, Attributes, 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_attributes_term(FlagsTerm, Flags) ->
+ parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm,
+ ordinary(C_Code, yes(Context)), VarSet, Result)
+ ; parse_pragma_c_code_attributes_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 +139,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_attributes_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 +163,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 +171,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 +195,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 +207,7 @@
parse_pragma_type(ModuleName, "import", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
(
- PragmaTerms = [PredAndModesTerm, MayCallMercuryTerm,
+ PragmaTerms = [PredAndModesTerm, FlagsTerm,
C_FunctionTerm]
->
(
@@ -230,18 +229,18 @@
->
list__append(ArgModes, [RetMode], Modes),
(
- parse_may_call_mercury(MayCallMercuryTerm,
- MayCallMercury)
+ parse_pragma_c_code_attributes_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,18 @@
convert_mode_list(ModeTerms, Modes)
->
(
- parse_may_call_mercury(MayCallMercuryTerm,
- MayCallMercury)
+ parse_pragma_c_code_attributes_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 +278,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,
+ default_attributes(Attributes),
(
PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
@@ -305,7 +304,7 @@
->
list__append(ArgModes, [RetMode], Modes),
Result = ok(pragma(import(FuncName, function,
- Modes, MayCallMercury, C_Function)))
+ Modes, Attributes, C_Function)))
;
Result = error(
"expected pragma import(FuncName(ModeList) = Mode, C_Function)",
@@ -325,7 +324,7 @@
convert_mode_list(ModeTerms, Modes)
->
Result = ok(pragma(import(PredName, predicate,
- Modes, MayCallMercury, C_Function)))
+ Modes, Attributes, C_Function)))
;
Result = error(
"expected pragma import(PredName(ModeList), C_Function)",
@@ -679,6 +678,75 @@
Term = term__functor(term__atom(ExpectedKeyword), [Arg], _),
Arg = term__functor(term__string(StringArg), [], StartContext).
+%-----------------------------------------------------------------------------%
+
+:- type collected_pragma_c_code_attribute
+ ---> may_call_mercury(may_call_mercury)
+ ; thread_safe(thread_safe)
+ .
+
+:- pred parse_pragma_c_code_attributes_term(term, pragma_c_code_attributes).
+:- mode parse_pragma_c_code_attributes_term(in, out) is semidet.
+
+parse_pragma_c_code_attributes_term(Term, Attributes) :-
+ default_attributes(Attributes0),
+ parse_pragma_c_code_attributes_term0(Term, AttrList),
+ ( list__member(may_call_mercury(will_not_call_mercury), AttrList) ->
+ ( list__member(may_call_mercury(may_call_mercury), AttrList) ->
+ % XXX an error message would be nice
+ fail
+ ;
+ set_may_call_mercury(Attributes0,
+ will_not_call_mercury, Attributes1)
+ )
+ ;
+ Attributes1 = Attributes0
+ ),
+ ( list__member(thread_safe(thread_safe), AttrList) ->
+ ( list__member(thread_safe(not_thread_safe), AttrList) ->
+ % XXX an error message would be nice
+ fail
+ ;
+ set_thread_safe(Attributes1, thread_safe, Attributes)
+ )
+ ;
+ Attributes = Attributes1
+ ).
+
+:- pred parse_pragma_c_code_attributes_term0(term,
+ list(collected_pragma_c_code_attribute)).
+:- mode parse_pragma_c_code_attributes_term0(in, out) is semidet.
+
+parse_pragma_c_code_attributes_term0(Term, Flags) :-
+ (
+ parse_single_pragma_c_code_attribute(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_attribute(Hd, Flag),
+ parse_pragma_c_code_attributes_term0(Tl, Flags0)
+ )
+ ).
+
+:- pred parse_single_pragma_c_code_attribute(term,
+ collected_pragma_c_code_attribute).
+:- mode parse_single_pragma_c_code_attribute(in, out) is semidet.
+
+parse_single_pragma_c_code_attribute(Term, Flag) :-
+ ( parse_may_call_mercury(Term, MayCallMercury) ->
+ Flag = may_call_mercury(MayCallMercury)
+ ; parse_threadsafe(Term, ThreadSafe) ->
+ Flag = thread_safe(ThreadSafe)
+ ;
+ fail
+ ).
+
:- pred parse_may_call_mercury(term, may_call_mercury).
:- mode parse_may_call_mercury(in, out) is semidet.
@@ -691,13 +759,21 @@
parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
_), will_not_call_mercury).
+:- pred parse_threadsafe(term, thread_safe).
+:- mode parse_threadsafe(in, out) is semidet.
+
+parse_threadsafe(term__functor(term__atom("thread_safe"), [], _),
+ thread_safe).
+parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _),
+ not_thread_safe).
+
% parse a pragma c_code declaration
-:- pred parse_pragma_c_code(module_name, may_call_mercury, term,
+:- pred parse_pragma_c_code(module_name, pragma_c_code_attributes, 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 +808,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.2
diff -u -r1.2 table_gen.m
--- table_gen.m 1998/07/24 01:45:33 1.2
+++ table_gen.m 1998/08/04 04:34:16
@@ -654,8 +654,10 @@
TableVarMode = (free -> TableVarInst),
get_table_var_type(TableVarType),
- GoalEx = pragma_c_code(will_not_call_mercury, PredId, ProcId,
- [TableVar], [yes("MC_table_var" - TableVarMode)],
+ default_attributes(Attrs0),
+ set_may_call_mercury(Attrs0, will_not_call_mercury, Attrs),
+ GoalEx = pragma_c_code(Attrs, PredId, ProcId, [TableVar],
+ [yes("MC_table_var" - TableVarMode)],
[TableVarType], ordinary(
" {
static Word MR_table = 0;
@@ -663,8 +665,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.100
diff -u -r1.100 reference_manual.texi
--- reference_manual.texi 1998/07/26 15:49:40 1.100
+++ reference_manual.texi 1998/08/06 00:21:52
@@ -3197,7 +3197,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
@@ -3245,6 +3245,24 @@
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.)
+
+All Mercury implementations must support the attributes described below.
+They may also support additional attributes.
+
+The attributes which must be supported by all implementations
+are as follows:
+ at table @asis
+
+ at item @samp{may_call_mercury}/@samp{will_not_call_mercury} declares
+whether or not execution inside this C code may call back into Mercury
+or not.
+
+ at item @samp{thread_safe}/@samp{not_thread_safe} declares whether or not
+it is safe for multiple threads to execute this C code concurrently.
+C code that is not thread_safe has code inserted around it to obtain
+and release a mutex. All non-thread-safe 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/exceptions
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
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.9
diff -u -r1.9 mercury_context.c
--- mercury_context.c 1998/07/28 01:01:38 1.9
+++ mercury_context.c 1998/07/31 05:44:49
@@ -54,6 +54,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.12
diff -u -r1.12 mercury_engine.c
--- mercury_engine.c 1998/07/22 07:52:37 1.12
+++ mercury_engine.c 1998/08/06 01:45:44
@@ -116,6 +116,7 @@
#ifdef MR_THREAD_SAFE
eng->owner_thread = pthread_self();
eng->c_depth = 0;
+ eng->saved_owners = NULL;
#endif
/*
@@ -232,9 +233,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
@@ -251,6 +249,11 @@
** This technique should work and should be vaguely portable,
** just so long as local variables and temporaries are allocated in
** the same way in every function.
+ **
+ ** WARNING!
+ ** Do not add local variables to call_engine_inner that you expect
+ ** to remain live across Mercury execution - Mercury execution will
+ ** scribble on the stack frame for this function.
*/
unsigned char locals[LOCALS_SIZE];
@@ -295,8 +298,17 @@
*/
#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
/*
@@ -306,16 +318,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;
+ oldmem(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.8
diff -u -r1.8 mercury_engine.h
--- mercury_engine.h 1998/07/22 07:52:39 1.8
+++ mercury_engine.h 1998/08/05 01:04:02
@@ -151,6 +151,13 @@
/*---------------------------------------------------------------------------*/
+#ifdef MR_THREAD_SAFE
+typedef struct MR_mercury_thread_list_struct {
+ MercuryThread thread;
+ struct MR_mercury_thread_list_struct *next;
+} MercuryThreadList;
+#endif
+
/*
** The Mercury engine structure.
** Normally there is one of these for each Posix thread.
@@ -180,8 +187,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 +201,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.3
diff -u -r1.3 mercury_thread.c
--- mercury_thread.c 1998/07/22 07:53:19 1.3
+++ mercury_thread.c 1998/08/06 00:27:32
@@ -19,19 +19,22 @@
#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);
MR_MAKE_STACK_LAYOUT_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;
@@ -39,7 +42,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",
@@ -51,11 +54,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;
eng = create_engine();
@@ -87,13 +107,19 @@
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 NULL;
}
#ifdef MR_THREAD_SAFE
@@ -156,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
--- mercury_thread.h 1998/06/15 07:00:16 1.2
+++ mercury_thread.h 1998/08/06 00:32:41
@@ -52,6 +52,17 @@
#define MR_WAIT(cnd, mtx) MR_cond_wait((cnd), (mtx))
#endif
+ /*
+ ** The following two macros are used to protect pragma c_code
+ ** predicates which are not thread-safe.
+ ** See the comments below.
+ */
+ #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 +75,36 @@
#define MR_KEY_CREATE pthread_key_create
#endif
- MercuryThread *create_thread(int x);
+ typedef struct {
+ void (*func)(void *);
+ void *arg;
+ } MR_ThreadGoal;
+
+ /*
+ ** create_thread(Goal) creates a new POSIX thread, and creates and
+ ** initializes a new Mercury engine to run in that thread. If Goal
+ ** is a NULL pointer, that thread will suspend on the global Mercury
+ ** runqueue. If Goal is non-NULL, it is a pointer to a MR_ThreadGoal
+ ** structure containing a function and an argument. The function will
+ ** be called with the given argument in the new thread.
+ */
+ 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 the C code fragment, and then
+ ** release it afterwards.
+ ** 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 +113,29 @@
#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. The engine is destroyed when the execution of work from
+** the runqueue returns.
+*/
+typedef enum { MR_use_now, MR_use_later } MR_when_to_use;
+
+/*
+** Create and initialize a new Mercury engine running in the current
+** POSIX thread.
+** See the comments above for the meaning of the argument.
+*/
+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.20
diff -u -r1.20 mercury_wrapper.c
--- mercury_wrapper.c 1998/07/27 18:04:32 1.20
+++ mercury_wrapper.c 1998/07/31 05:45:00
@@ -166,6 +166,7 @@
#endif
Declare_entry(do_interpreter);
+Declare_entry(do_runnext);
/*---------------------------------------------------------------------------*/
@@ -258,15 +259,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.52
diff -u -r1.52 mgnuc.in
--- mgnuc.in 1998/07/01 07:41:46 1.52
+++ mgnuc.in 1998/07/31 05:45:12
@@ -274,7 +274,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
More information about the developers
mailing list