[m-rev.] for review: thread safe mutables (part 2)
Julien Fischer
juliensf at csse.unimelb.edu.au
Tue Aug 29 17:28:43 AEST 2006
Estimated hours taken: 12
Branches: main
Make the get and set operations for non-constant mutables thread safe. (The
get operation for constant mutables is thread safe by definition.) The
source-to-source transformation for (non-constant) mutables is modified as
follows: we introduce four primitive operations: unsafe_get, unsafe_set, lock
and unlock. These operations are private implementation details. The first
two read and write the value of the mutable. In .par grades lock and unlock
are used to respectively acquire and release the mutex associated with
a mutable. In non .par grades they are no-ops.
The user-level mutable operations are now defined in terms of these
primitives. In particular get and set must acquire the mutable's mutex before
they can read or modify its value. (We will shortly add support for atomic
updates to mutables - defined in terms of the above primitives - as well.)
Fix intermodule inlining so that the clauses for the mutable access predicates
are written to .opt files even though they contain calls to impure predicates.
This is usually not allowed because of problems caused be reordering what were
headvar unifications in the original source file. It's okay to do this for
the mutable access predicates since we can guarantee that they won't need to
be reordered by construction.
compiler/make_hlds_passes.m:
Add declarations and implementation for: unsafe_{get,set}, lock
and unlock.
Redefine get/1, set/1, get/3 and set/3 in terms of the above
operations. In .par grades acquire the mutable's mutex before reading
or writing to it and release it afterwards.
Fill in the item_origin field for predicate declarations introduced by
the source-to-source transformation for mutables.
compiler/prog_mutable.m:
Add auxiliary predicates required by the above.
Update the description of the mutable source-to-source transformation.
compiler/prog_util.m:
Add a function: goal_list_to_conj/2. This is needed by the mutable
transformation.
compiler/add_clauses.m:
Delete the function goal_list_to_goal/2 which is identical
to goal_list_to_conj/2 but for the name.
compiler/prog_item.m:
Add an origin field to the pred_or_func item.
compiler/hlds_pred.m:
Add a new pred_marker for identifying predicates that were introduced
by the mutable source-to-source transformation.
compiler/add_pragma.m:
Fill in the item_origin field for the predicate declarations introduced
by tabling pragmas.
compiler/intermod.m:
Mutable access predicates should always be written to the .opt files
if they are referred to by an opt_exported predicate.
Remove the restriction that clauses that call impure predicates should
not be opt_exported in the case where the clause in question was
introduced by the mutable transformation. For those clauses we can
guarantee that there won't be any problems associated with reordering
(the reason given for the restriction) by construction.
Rename some variables.
compiler/prog_io.m:
Fill in the origin field for pred_or_func items.
compiler/add_pred.m:
compiler/equiv_type.m:
compiler/hlds_out.m:
compiler/inlining:
compiler/mercury_to_mercury.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/prog_io_goal.m:
compiler/prog_io_typeclass.m:
compiler/recompilation.check.m:
compiler/recompilation.version.m:
compiler/table_gen.m:
Conform to the above changes.
TODO: update reference manual to mention the new behaviour of mutables in
grades that support concurrency.
Julien.
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.29
diff -u -r1.29 add_clause.m
--- compiler/add_clause.m 22 Aug 2006 05:03:37 -0000 1.29
+++ compiler/add_clause.m 25 Aug 2006 08:21:13 -0000
@@ -648,7 +648,7 @@
),
Reason = trace_goal(MaybeCompileTime, MaybeRunTime, MaybeIOHLDS,
MutableHLDSs),
- Goal1 = goal_list_to_goal(Context, GetGoals ++ [Goal0] ++ SetGoals),
+ Goal1 = goal_list_to_conj(Context, GetGoals ++ [Goal0] ++ SetGoals),
BeforeSInfo = !.SInfo,
substitute_vars(StateVars0, Subst, StateVars),
prepare_for_local_state_vars(StateVars, !VarSet, !SInfo),
@@ -856,18 +856,6 @@
GetGoal = call_expr(GetPredName, [SetVar], Purity) - Context,
SetGoal = call_expr(SetPredName, [UseVar], Purity) - Context.
-:- func goal_list_to_goal(prog_context, list(goal)) = goal.
-
-goal_list_to_goal(Context, []) = true_expr - Context.
-goal_list_to_goal(Context, [Goal | Goals]) =
- goal_list_to_goal_2(Context, Goal, Goals).
-
-:- func goal_list_to_goal_2(prog_context, goal, list(goal)) = goal.
-
-goal_list_to_goal_2(_, Goal, []) = Goal.
-goal_list_to_goal_2(Context, Goal0, [Goal1 | Goals]) =
- conj_expr(Goal0, goal_list_to_goal_2(Context, Goal1, Goals)) - Context.
-
:- pred transform_promise_eqv_goal(prog_vars::in, prog_vars::in, prog_vars::in,
prog_substitution::in, prog_context::in, prog_vars::out,
goal::in, hlds_goal::out, hlds_goal_info::out, int::out,
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.45
diff -u -r1.45 add_pragma.m
--- compiler/add_pragma.m 22 Aug 2006 05:03:37 -0000 1.45
+++ compiler/add_pragma.m 28 Aug 2006 08:37:19 -0000
@@ -2021,7 +2021,8 @@
WithType = no,
WithInst = no,
Condition = cond_true,
- StatsPredDecl = item_pred_or_func(VarSet0, InstVarSet, ExistQVars,
+ Origin = compiler(pragma_memo_attribute),
+ StatsPredDecl = item_pred_or_func(Origin, VarSet0, InstVarSet, ExistQVars,
predicate, StatsPredSymName, ArgDecls, WithType, WithInst,
yes(detism_det), Condition, purity_pure, Constraints),
ItemStatus0 = item_status(!.Status, may_be_unqualified),
@@ -2076,7 +2077,8 @@
WithType = no,
WithInst = no,
Condition = cond_true,
- ResetPredDecl = item_pred_or_func(VarSet0, InstVarSet, ExistQVars,
+ Origin = compiler(pragma_memo_attribute),
+ ResetPredDecl = item_pred_or_func(Origin, VarSet0, InstVarSet, ExistQVars,
predicate, ResetPredSymName, ArgDecls, WithType, WithInst,
yes(detism_det), Condition, purity_pure, Constraints),
ItemStatus0 = item_status(!.Status, may_be_unqualified),
Index: compiler/add_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pred.m,v
retrieving revision 1.21
diff -u -r1.21 add_pred.m
--- compiler/add_pred.m 22 Aug 2006 05:03:37 -0000 1.21
+++ compiler/add_pred.m 28 Aug 2006 08:29:57 -0000
@@ -6,8 +6,12 @@
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
+% File: add_pred.m.
+%
% This submodule of make_hlds handles the type and mode declarations
% for predicates.
+%
+%-----------------------------------------------------------------------------%
:- module hlds.make_hlds.add_pred.
:- interface.
@@ -61,6 +65,9 @@
prog_context::in, pred_or_func::in, pred_id::out,
predicate_table::in, predicate_table::out) is det.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- implementation.
:- import_module hlds.hlds_data.
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.66
diff -u -r1.66 equiv_type.m
--- compiler/equiv_type.m 22 Aug 2006 05:03:43 -0000 1.66
+++ compiler/equiv_type.m 28 Aug 2006 08:42:26 -0000
@@ -292,12 +292,12 @@
finish_recording_expanded_items(ItemId, UsedTypeCtors, !Info).
replace_in_item(ModuleName,
- item_pred_or_func(TypeVarSet0, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes0, MaybeWithType0,
+ item_pred_or_func(Origin, TypeVarSet0, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes0, MaybeWithType0,
MaybeWithInst0, Det0, Cond, Purity, ClassContext0),
Context, EqvMap, EqvInstMap,
- item_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, MaybeWithType,
+ item_pred_or_func(Origin, TypeVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes, MaybeWithType,
MaybeWithInst, Det, Cond, Purity, ClassContext),
Errors, !Info) :-
maybe_record_expanded_items(ModuleName, PredName,
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.399
diff -u -r1.399 hlds_out.m
--- compiler/hlds_out.m 22 Aug 2006 05:03:47 -0000 1.399
+++ compiler/hlds_out.m 28 Aug 2006 09:11:07 -0000
@@ -1017,6 +1017,7 @@
marker_name(marker_calls_are_fully_qualified, "calls_are_fully_qualified").
marker_name(marker_mode_check_clauses, "mode_check_clauses").
marker_name(marker_may_have_parallel_conj, "may_have_parallel_conj").
+marker_name(marker_mutable_access_pred, "mutable_access_pred").
write_marker(Marker, !IO) :-
marker_name(Marker, Name),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.207
diff -u -r1.207 hlds_pred.m
--- compiler/hlds_pred.m 22 Aug 2006 05:03:47 -0000 1.207
+++ compiler/hlds_pred.m 28 Aug 2006 09:08:15 -0000
@@ -399,11 +399,17 @@
% inst_match.bound_inst_list_contains_instname and
% instmap.merge) would be unacceptable.
- ; marker_may_have_parallel_conj.
+ ; marker_may_have_parallel_conj
% The predicate may contain parallel conjunctions.
% It should be run through the dependent parallel
% conjunction transformation.
+ ; marker_mutable_access_pred.
+ % This predicate is part of the machinery used to
+ % access mutables. This marker is used to inform
+ % inlining that we should _always_ attempt to
+ % inline this predicate across module boundaries.
+
% An abstract set of attributes.
:- type pred_attributes.
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.145
diff -u -r1.145 inlining.m
--- compiler/inlining.m 20 Aug 2006 08:21:11 -0000 1.145
+++ compiler/inlining.m 29 Aug 2006 06:44:42 -0000
@@ -14,7 +14,7 @@
% * (--inline-simple and --inline-simple-threshold N)
% procedures whose size is below the given threshold,
% PLUS
-% procedures that are flat (ie contain no branched structures)
+% procedures that are flat (i.e. contain no branched structures)
% and are composed of inline builtins (eg arithmetic),
% and whose size is less than three times the given threshold
% (XXX shouldn't hard-code 3)
@@ -38,7 +38,7 @@
% It builds the call-graph (if necessary) works from the bottom of the
% call-graph towards the top, first performing inlining on a procedure,
% then deciding if calls to it (higher in the call-graph) should be inlined.
-% SCCs get flattend and processed in the order returned by
+% SCCs get flattened and processed in the order returned by
% hlds_dependency_info_get_dependency_ordering.
%
% There are a couple of classes of procedure that we clearly want to inline
@@ -174,6 +174,7 @@
:- import_module maybe.
:- import_module pair.
:- import_module set.
+:- import_module svset.
:- import_module term.
:- import_module varset.
@@ -370,9 +371,8 @@
:- pred mark_proc_as_inlined(pred_proc_id::in, module_info::in,
set(pred_proc_id)::in, set(pred_proc_id)::out, io::di, io::uo) is det.
-mark_proc_as_inlined(proc(PredId, ProcId), ModuleInfo,
- !InlinedProcs, !IO) :-
- set.insert(!.InlinedProcs, proc(PredId, ProcId), !:InlinedProcs),
+mark_proc_as_inlined(proc(PredId, ProcId), ModuleInfo, !InlinedProcs, !IO) :-
+ svset.insert(proc(PredId, ProcId), !InlinedProcs),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
( pred_info_requested_inlining(PredInfo) ->
true
@@ -383,13 +383,13 @@
%-----------------------------------------------------------------------------%
- % inline_info contains the information that is changed as a result
- % of inlining. It is threaded through the inlining process, and when
- % finished, contains the updated information associated with the new
- % goal.
- %
- % It also stores some necessary information that is not updated.
-
+ % inline_info contains the information that is changed as a result
+ % of inlining. It is threaded through the inlining process, and when
+ % finished, contains the updated information associated with the new
+ % goal.
+ %
+ % It also stores some necessary information that is not updated.
+ %
:- type inline_info
---> inline_info(
i_var_threshold :: int,
@@ -986,7 +986,7 @@
ok_to_inline_language(lang_c, target_c).
% ok_to_inline_language(il, il). %
-% XXX we need to fix the handling of parameter marhsalling for inlined code
+% XXX we need to fix the handling of parameter marshalling for inlined code
% before we can enable this -- see the comments in
% ml_gen_ordinary_pragma_il_proc in ml_code_gen.m.
%
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.205
diff -u -r1.205 intermod.m
--- compiler/intermod.m 22 Aug 2006 05:03:48 -0000 1.205
+++ compiler/intermod.m 29 Aug 2006 06:47:34 -0000
@@ -146,14 +146,14 @@
module_info_get_name(!.ModuleInfo, ModuleName),
module_name_to_file_name(ModuleName, ".opt.tmp", yes, TmpName, !IO),
- io.open_output(TmpName, Result2, !IO),
+ io.open_output(TmpName, Result, !IO),
(
- Result2 = error(Err2),
- io.error_message(Err2, Msg2),
- io.write_string(Msg2, !IO),
+ Result = error(Err),
+ Msg = io.error_message(Err),
+ io.write_string(Msg, !IO),
io.set_exit_status(1, !IO)
;
- Result2 = ok(FileStream),
+ Result = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
module_info_predids(!.ModuleInfo, RealPredIds),
module_info_get_assertion_table(!.ModuleInfo, AssertionTable),
@@ -183,12 +183,14 @@
)
)
),
- % restore the option setting that we overrode above
+ %
+ % Restore the option setting that we overrode above.
+ %
globals.io_set_option(line_numbers, bool(LineNumbers), !IO).
%-----------------------------------------------------------------------------%
%
-% Predicates to gather stuff to output to .opt file
+% Predicates to gather items to output to .opt file
%
:- pred gather_preds(list(pred_id)::in, bool::in, int::in, int::in, bool::in,
@@ -200,8 +202,9 @@
ProcessLocalPreds = no,
gather_pred_list(AllPredIds, ProcessLocalPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info),
-
+ %
% Then gather preds used by exported preds (recursively).
+ %
set.init(ExtraExportedPreds0),
gather_preds_2(ExtraExportedPreds0, CollectTypes, InlineThreshold,
HigherOrderSizeLimit, Deforestation, !Info).
@@ -272,8 +275,8 @@
module_info_set_preds(PredTable, ModuleInfo0, ModuleInfo),
intermod_info_get_preds(!.Info, Preds0),
( pred_info_pragma_goal_type(PredInfo) ->
- % The header code must be written since
- % it could be used by the pragma_foreign_code.
+ % pragma foreign_decls must be written since their contents
+ % could be used by pragma foreign_procs.
intermod_info_set_write_header(!Info)
;
true
@@ -353,6 +356,10 @@
;
pred_info_requested_inlining(PredInfo)
;
+ % Mutable access preds should always be included in .opt files.
+ %
+ check_marker(Markers, marker_mutable_access_pred)
+ ;
has_ho_input(ModuleInfo, ProcInfo),
clause_list_size(Clauses, GoalSize),
GoalSize =< HigherOrderSizeLimit + Arity
@@ -623,9 +630,15 @@
% is read in. The `C = HeadVar3' unification cannot be reordered
% with the impure goal, resulting in a mode error. Fixing this
% in mode analysis would be tricky.
- %
% See tests/valid/impure_intermod.m.
- pred_info_get_purity(PredInfo, purity_impure)
+ %
+ % NOTE: the above restriction applies to user predicates. For
+ % the compiler generated mutable access predicates we can ensure
+ % that reordering is not necessary by construction, so it's safe
+ % to include them in .opt files.
+ %
+ pred_info_get_purity(PredInfo, purity_impure),
+ not check_marker(Markers, marker_mutable_access_pred)
->
DoWrite = no
;
@@ -1802,6 +1815,7 @@
should_output_marker(marker_calls_are_fully_qualified, no).
should_output_marker(marker_mode_check_clauses, yes).
should_output_marker(marker_may_have_parallel_conj, no).
+should_output_marker(marker_mutable_access_pred, no). % XXX should be yes.
:- pred get_pragma_foreign_code_vars(list(foreign_arg)::in, list(mer_mode)::in,
prog_varset::in, prog_varset::out, list(pragma_var)::out) is det.
@@ -1838,38 +1852,34 @@
%-----------------------------------------------------------------------------%
- % a collection of stuff to go in the .opt file
+ % A collection of stuff to go in the .opt file.
+ %
:- type intermod_info
---> info(
- im_modules :: set(module_name),
- % modules to import
+ im_modules :: set(module_name),
+ % Modules to import.
- im_preds :: set(pred_id),
- % preds to output clauses for
+ im_preds :: set(pred_id),
+ % Preds to output clauses for.
- im_pred_decls :: set(pred_id),
- % preds to output decls for
+ im_pred_decls :: set(pred_id),
+ % Preds to output decls for.
- im_instances :: assoc_list(class_id,
- hlds_instance_defn),
- % instances declarations to write
+ im_instances :: assoc_list(class_id, hlds_instance_defn),
+ % Instances declarations to write.
- im_types :: assoc_list(type_ctor,
- hlds_type_defn),
- % type declarations to write
+ im_types :: assoc_list(type_ctor, hlds_type_defn),
+ % Type declarations to write.
- im_module_info :: module_info,
+ im_module_info :: module_info,
im_write_foreign_header :: bool,
- % do the c_header_codes for the module
- % need writing, yes if there are
- % pragma_foreign_code procs being
- % exported.
-
- im_var_types :: vartypes,
- im_tvarset :: tvarset
- % Vartypes and tvarset for the
- % current pred.
+ % Do the pragma foreign_decls for the module need writing,
+ % yes if there are pragma foreign_procs being exported.
+
+ im_var_types :: vartypes,
+ im_tvarset :: tvarset
+ % Vartypes and tvarset for the current pred.
).
:- pred init_intermod_info(module_info::in, intermod_info::out) is det.
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.50
diff -u -r1.50 make_hlds_passes.m
--- compiler/make_hlds_passes.m 22 Aug 2006 09:41:15 -0000 1.50
+++ compiler/make_hlds_passes.m 29 Aug 2006 06:48:49 -0000
@@ -263,10 +263,9 @@
% Add the type definitions and pragmas one by one to the module,
% and add default modes for functions with no mode declaration.
%
- % Adding type definitions needs to come after we have added the
- % pred declarations,
- % since we need to have the pred_id for `index/2' and `compare/3'
- % when we add compiler-generated clauses for `compare/3'.
+ % Adding type definitions needs to come after we have added the pred
+ % declarations, since we need to have the pred_id for `index/2' and
+ % `compare/3' when we add compiler-generated clauses for `compare/3'.
% (And similarly for other compiler-generated predicates like that.)
%
% Adding pragmas needs to come after we have added the
@@ -292,10 +291,11 @@
% Check that the declarations for field extraction and update functions
% are sensible.
%
- % Check that predicates listed in `:- initialise' declarations exist
- % and have the right signature, introduce pragma export declarations
- % for them and record their exported name in the module_info so that
- % we can tell the code generator to call it at initialisation time.
+ % Check that predicates listed in `:- initialise' and `:- finalise'
+ % declarations exist and have the correct signature, introduce
+ % pragma export declarations for them and record their exported name in
+ % the module_info so that we can tell the code generator to call it at
+ % initialisation/finalisation time.
%
:- pred add_item_list_clauses(item_list::in, import_status::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
@@ -341,13 +341,37 @@
module_add_mode_defn(VarSet, Name, Params, ModeDefn,
Cond, Context, !.Status, !ModuleInfo, InvalidMode, !IO).
add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = item_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
- Purity, ClassContext),
- init_markers(Markers),
- module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, MaybeDet, Purity, ClassContext, Markers,
- Context, !.Status, _, !ModuleInfo, !IO).
+ Item = item_pred_or_func(Origin, TypeVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes, _WithType, _WithInst, MaybeDet,
+ _Cond, Purity, ClassContext),
+ init_markers(Markers0),
+ %
+ % If this predicate was added as a result of the mutable transformation
+ % then mark this predicate ad a mutable access pred. We do this
+ % so that we can tell optimizations, like inlining, to treat it
+ % specially.
+ %
+ (
+ Origin = compiler(Reason),
+ (
+ Reason = mutable_decl,
+ add_marker(marker_mutable_access_pred, Markers0, Markers)
+ ;
+ ( Reason = initialise_decl
+ ; Reason = finalise_decl
+ ; Reason = solver_type
+ ; Reason = pragma_memo_attribute
+ ; Reason = foreign_imports
+ ),
+ Markers = Markers0
+ )
+ ;
+ Origin = user,
+ Markers = Markers0
+ ),
+ module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes, MaybeDet, Purity, ClassContext,
+ Markers, Context, !.Status, _, !ModuleInfo, !IO).
add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
Item = item_pred_or_func_mode(VarSet, MaybePredOrFunc, PredName, Modes,
_WithInst, MaybeDet, _Cond),
@@ -474,6 +498,23 @@
InitMutexPredDecl = mutable_init_mutex_pred_decl(ModuleName, Name),
add_item_decl_pass_1(InitMutexPredDecl, Context, !Status,
!ModuleInfo, _, !IO),
+ %
+ % Create the primitive access and locking predicates.
+ %
+ LockPredDecl = lock_pred_decl(ModuleName, Name),
+ add_item_decl_pass_1(LockPredDecl, Context, !Status,
+ !ModuleInfo, _, !IO),
+ UnlockPredDecl = unlock_pred_decl(ModuleName, Name),
+ add_item_decl_pass_1(UnlockPredDecl, Context, !Status,
+ !ModuleInfo, _, !IO),
+ UnsafeGetPredDecl = unsafe_get_pred_decl(ModuleName, Name,
+ Type, Inst),
+ add_item_decl_pass_1(UnsafeGetPredDecl, Context, !Status,
+ !ModuleInfo, _, !IO),
+ UnsafeSetPredDecl = unsafe_set_pred_decl(ModuleName, Name,
+ Type, Inst),
+ add_item_decl_pass_1(UnsafeSetPredDecl, Context, !Status,
+ !ModuleInfo, _, !IO),
%
% Create the standard, non-pure access predicates. These are
% always created for non-constant mutables, even if the
@@ -560,7 +601,7 @@
Item = item_pragma(Origin, Pragma),
add_pragma(Origin, Pragma, Context, !Status, !ModuleInfo, !IO).
add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
- Item = item_pred_or_func(_TypeVarSet, _InstVarSet, _ExistQVars,
+ Item = item_pred_or_func(_Origin, _TypeVarSet, _InstVarSet, _ExistQVars,
PredOrFunc, SymName, TypesAndModes, _WithType, _WithInst,
_MaybeDet, _Cond, _Purity, _ClassContext),
%
@@ -694,6 +735,22 @@
ReportErrors = yes,
get_global_name_from_foreign_names(ReportErrors, Context,
ModuleName, Name, ForeignNames, _TargetMutableName, !IO)
+ ),
+ %
+ % If we are creating the I/O version of the set predicate then we
+ % need to add a promise_pure pragma for it. This needs to be done
+ % here (in stage 2) rather than in stage 3 where the rest of the
+ % mutable transformation is.
+ %
+ IOStateInterface = mutable_var_attach_to_io_state(MutAttrs),
+ (
+ IOStateInterface = yes,
+ SetPredName = mutable_set_pred_sym_name(ModuleName, Name),
+ IOSetPromisePurePragma = pragma_promise_pure(SetPredName, 3),
+ add_pragma(compiler(mutable_decl), IOSetPromisePurePragma,
+ Context, !Status, !ModuleInfo, !IO)
+ ;
+ IOStateInterface = no
)
;
NYIError = [
@@ -828,7 +885,7 @@
add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
Item = item_mode_defn(_, _, _, _, _).
add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = item_pred_or_func(_, _, _, PredOrFunc, SymName, TypesAndModes,
+ Item = item_pred_or_func(_, _, _, _, PredOrFunc, SymName, TypesAndModes,
_WithType, _WithInst, _, _, _, _),
(
PredOrFunc = predicate
@@ -1221,15 +1278,16 @@
decide_mutable_target_var_name(MutAttrs, ModuleName,
MercuryMutableName, Context, TargetMutableName, !IO),
%
- % Add foreign_decl and foreign_code items that declare/define
- % the global variable.
+ % Add foreign_decl and foreign_code items that declare/define the
+ % global variable used to implement the mutable. If the mutable is
+ % not constant then add a mutex to synchronize access to it as well.
%
add_mutable_defn_and_decl(TargetMutableName, Type, IsConstant,
Context, !QualInfo, !ModuleInfo, !IO),
%
% Set up the default attributes for the foreign_procs used for the
% access predicates.
- % XXX Handle languages other than C here.
+ % XXX Handle target languages other than C here.
%
Attrs0 = default_attributes(lang_c),
globals.io_lookup_bool_option(mutable_always_boxed, AlwaysBoxed, !IO),
@@ -1254,9 +1312,11 @@
IsConstant = no,
InitSetPredName = mutable_set_pred_sym_name(ModuleName,
MercuryMutableName),
- add_mutable_access_preds(TargetMutableName, ModuleName,
+ add_mutable_primitive_preds(TargetMutableName, ModuleName,
MercuryMutableName, MutAttrs, Attrs, Inst, BoxPolicy, Context,
- !Status, !QualInfo, !ModuleInfo, !IO)
+ !Status, !QualInfo, !ModuleInfo, !IO),
+ add_mutable_user_access_preds(ModuleName, MercuryMutableName,
+ MutAttrs, Context, !Status, !QualInfo, !ModuleInfo, !IO)
),
add_mutable_initialisation(IsConstant, TargetMutableName, ModuleName,
MercuryMutableName, MutVarset, InitSetPredName, InitTerm, Attrs,
@@ -1364,39 +1424,85 @@
add_item_clause(ConstantSetClause, !Status, Context, !ModuleInfo,
!QualInfo, !IO).
- % Add the access predicates for a non-constant mutable.
- % If the mutable has the `attach_to_io_state' attribute then add the
- % versions of the access preds that take the I/O state as well.
+ % Add the foreign clauses for the mutable's primitive access and
+ % locking predicates.
%
-:- pred add_mutable_access_preds(string::in, module_name::in, string::in,
+:- pred add_mutable_primitive_preds(string::in, module_name::in, string::in,
mutable_var_attributes::in, pragma_foreign_proc_attributes::in,
mer_inst::in, box_policy::in, prog_context::in,
import_status::in, import_status::out, qual_info::in, qual_info::out,
module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_mutable_access_preds(TargetMutableName, ModuleName, Name,
+
+add_mutable_primitive_preds(TargetMutableName, ModuleName, Name,
MutAttrs, Attrs, Inst, BoxPolicy, Context, !Status, !QualInfo,
!ModuleInfo, !IO) :-
- varset.new_named_var(varset.init, "X", X, ProgVarSet0),
- InstVarSet = varset.init,
+ set_thread_safe(proc_thread_safe, Attrs, LockAndUnlockAttrs),
%
- % Construct the semipure get predicate.
+ % Construct the lock predicate.
%
- set_purity(purity_semipure, Attrs, GetAttrs),
- StdGetForeignProc = pragma_foreign_proc(GetAttrs,
- mutable_get_pred_sym_name(ModuleName, Name),
+ MutableMutexVarName = mutable_mutex_var_name(TargetMutableName),
+ % XXX the second argument should be the name of the mercury predicate,
+ % with chars escaped as appropriate.
+ LockForeignProcBody = string.append_list([
+ "#ifdef MR_THREAD_SAFE\n",
+ " MR_LOCK(&" ++ MutableMutexVarName ++ ",
+ \"" ++ MutableMutexVarName ++ "\");\n" ++
+ "#endif\n"
+ ]),
+ LockForeignProc = pragma_foreign_proc(LockAndUnlockAttrs,
+ mutable_lock_pred_sym_name(ModuleName, Name),
+ predicate,
+ [],
+ varset.init, % Prog varset.
+ varset.init, % Inst varset.
+ fc_impl_ordinary(LockForeignProcBody, yes(Context))
+ ),
+ LockClause = item_pragma(compiler(mutable_decl), LockForeignProc),
+ add_item_clause(LockClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
+ %
+ % Construct the unlock predicate.
+ %
+ % XXX as above regarding the second argument to MR_UNLOCK.
+ UnlockForeignProcBody = string.append_list([
+ "#ifdef MR_THREAD_SAFE\n",
+ " MR_UNLOCK(&" ++ MutableMutexVarName ++ ",
+ \"" ++ MutableMutexVarName ++ "\");\n" ++
+ "#endif\n"
+ ]),
+ UnlockForeignProc = pragma_foreign_proc(LockAndUnlockAttrs,
+ mutable_unlock_pred_sym_name(ModuleName, Name),
+ predicate,
+ [],
+ varset.init, % Prog varset.
+ varset.init, % Inst varset.
+ fc_impl_ordinary(UnlockForeignProcBody, yes(Context))
+ ),
+ UnlockClause = item_pragma(compiler(mutable_decl), UnlockForeignProc),
+ add_item_clause(UnlockClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
+ %
+ % Construct the semipure unsafe_get_predicate.
+ %
+ set_purity(purity_semipure, Attrs, UnsafeGetAttrs0),
+ set_thread_safe(proc_thread_safe, UnsafeGetAttrs0, UnsafeGetAttrs),
+ varset.new_named_var(varset.init, "X", X, ProgVarSet),
+ UnsafeGetForeignProc = pragma_foreign_proc(UnsafeGetAttrs,
+ mutable_unsafe_get_pred_sym_name(ModuleName, Name),
predicate,
[pragma_var(X, "X", out_mode(Inst), BoxPolicy)],
- ProgVarSet0,
- InstVarSet,
+ ProgVarSet,
+ varset.init, % Inst varset.
fc_impl_ordinary("X = " ++ TargetMutableName ++ ";", yes(Context))
),
- StdGetClause = item_pragma(compiler(mutable_decl), StdGetForeignProc),
- add_item_clause(StdGetClause, !Status, Context, !ModuleInfo, !QualInfo,
+ UnsafeGetClause = item_pragma(compiler(mutable_decl),
+ UnsafeGetForeignProc),
+ add_item_clause(UnsafeGetClause, !Status, Context, !ModuleInfo, !QualInfo,
!IO),
%
- % Construct the impure set predicate (by default it is trailed.)
+ % Construct the impure unsafe_set_predicate.
%
+ set_thread_safe(proc_thread_safe, Attrs, UnsafeSetAttrs),
TrailMutableUpdates = mutable_var_trailed(MutAttrs),
(
TrailMutableUpdates = mutable_untrailed,
@@ -1425,69 +1531,126 @@
TrailCode = ""
)
),
- StdSetForeignProc = pragma_foreign_proc(Attrs,
- mutable_set_pred_sym_name(ModuleName, Name),
+ UnsafeSetForeignProc = pragma_foreign_proc(UnsafeSetAttrs,
+ mutable_unsafe_set_pred_sym_name(ModuleName, Name),
predicate,
[pragma_var(X, "X", in_mode(Inst), BoxPolicy)],
- ProgVarSet0,
- InstVarSet,
- fc_impl_ordinary(TrailCode ++ TargetMutableName ++ " = X;",
+ ProgVarSet,
+ varset.init, % Inst varset.
+ fc_impl_ordinary(TrailCode ++ TargetMutableName ++ "= X;",
yes(Context))
),
- StdSetClause = item_pragma(compiler(mutable_decl),
- StdSetForeignProc),
- add_item_clause(StdSetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ UnsafeSetClause = item_pragma(compiler(mutable_decl),
+ UnsafeSetForeignProc),
+ add_item_clause(UnsafeSetClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO).
+
+ % Add the access predicates for a non-constant mutable.
+ % If the mutable has the `attach_to_io_state' attribute then add the
+ % versions of the access preds that take the I/O state as well.
%
- % Create access predicates for the mutable via the I/O state
- % if requested.
+:- pred add_mutable_user_access_preds(module_name::in, string::in,
+ mutable_var_attributes::in, prog_context::in,
+ import_status::in, import_status::out, qual_info::in, qual_info::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context,
+ !Status, !QualInfo, !ModuleInfo, !IO) :-
+ varset.new_named_var(varset.init, "X", X, ProgVarSet0),
+ LockPredName = mutable_lock_pred_sym_name(ModuleName, Name),
+ UnlockPredName = mutable_unlock_pred_sym_name(ModuleName, Name),
+ SetPredName = mutable_set_pred_sym_name(ModuleName, Name),
+ GetPredName = mutable_get_pred_sym_name(ModuleName, Name),
+ CallLock = call_expr(LockPredName, [], purity_impure) - Context,
+ CallUnlock = call_expr(UnlockPredName, [], purity_impure) - Context,
+ %
+ % Construct the semipure get predicate.
%
- % XXX We don't define these directly in terms of the non-pure
- % access predicates because I/O tabling doesn't currently work
- % for impure/semipure predicates. At the moment we just generate
- % another pair of foreign_procs.
+ UnsafeGetPredName = mutable_unsafe_get_pred_sym_name(ModuleName, Name),
+ UnsafeGetCallArgs = [variable(X)],
+ CallUnsafeGet = call_expr(UnsafeGetPredName, UnsafeGetCallArgs,
+ purity_semipure) - Context,
+
+ GetBody = goal_list_to_conj(Context,
+ [CallLock, CallUnsafeGet, CallUnlock]),
+ StdGetBody = promise_purity_expr(dont_make_implicit_promises,
+ purity_semipure, GetBody) - Context,
+
+ StdGetClause = item_clause(
+ compiler(mutable_decl),
+ ProgVarSet0,
+ predicate,
+ GetPredName,
+ [variable(X)],
+ StdGetBody
+ ),
+
+ add_item_clause(StdGetClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
%
+ % Construct the impure set predicate.
+ %
+ UnsafeSetPredName = mutable_unsafe_set_pred_sym_name(ModuleName, Name),
+ UnsafeSetCallArgs = [variable(X)],
+ StdSetCallUnsafeSet = call_expr(UnsafeSetPredName, UnsafeSetCallArgs,
+ purity_impure) - Context,
+
+ StdSetBody = goal_list_to_conj(Context,
+ [CallLock, StdSetCallUnsafeSet, CallUnlock]),
+
+ StdSetClause = item_clause(
+ compiler(mutable_decl),
+ ProgVarSet0,
+ predicate,
+ SetPredName,
+ [variable(X)],
+ StdSetBody
+ ),
+
+ add_item_clause(StdSetClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
+
IOStateInterface = mutable_var_attach_to_io_state(MutAttrs),
(
IOStateInterface = yes,
- IOArgs = [
- pragma_var(IO0, "IO0", di_mode, native_if_possible),
- pragma_var(IO, "IO", uo_mode, native_if_possible)
- ],
- set_tabled_for_io(proc_tabled_for_io, Attrs, IOIntAttrs0),
- set_purity(purity_pure, IOIntAttrs0, IOIntAttrs),
- varset.new_named_var(ProgVarSet0, "IO0", IO0, ProgVarSet1),
- varset.new_named_var(ProgVarSet1, "IO", IO, ProgVarSet),
- %
- % Construct the I/O set predicate.
- %
- IOSetForeignProc = pragma_foreign_proc(IOIntAttrs,
- mutable_set_pred_sym_name(ModuleName, Name),
- predicate,
- [ pragma_var(X, "X", in_mode(Inst), BoxPolicy) | IOArgs ],
+ varset.new_named_var(ProgVarSet0, "IO", IO, ProgVarSet),
+
+ % Construct the pure get predicate.
+ %
+ IOGetBody = promise_purity_expr(dont_make_implicit_promises,
+ purity_pure, GetBody) - Context,
+
+ IOGetClause = item_clause(
+ compiler(mutable_decl),
ProgVarSet,
- InstVarSet,
- fc_impl_ordinary(TargetMutableName ++ " = X; IO = IO0;",
- yes(Context))
+ predicate,
+ GetPredName,
+ [variable(X), variable(IO), variable(IO)],
+ IOGetBody
),
- IOSetClause = item_pragma(compiler(mutable_decl), IOSetForeignProc),
- add_item_clause(IOSetClause, !Status, Context, !ModuleInfo, !QualInfo,
+
+ add_item_clause(IOGetClause, !Status, Context, !ModuleInfo, !QualInfo,
!IO),
+
+ % Construct the pure set predicate.
%
- % Construct the I/O get predicate.
+ % We just use the body of impure version and attach a promise_pure
+ % pragma to the predicate. (The purity pragma was added during
+ % stage 2.)
%
- IOGetForeignProc = pragma_foreign_proc(IOIntAttrs,
- mutable_get_pred_sym_name(ModuleName, Name),
- predicate,
- [pragma_var(X, "X", out_mode(Inst), BoxPolicy) | IOArgs ],
+ IOSetBody = StdSetBody,
+
+ IOSetClause = item_clause(
+ compiler(mutable_decl),
ProgVarSet,
- InstVarSet,
- fc_impl_ordinary("X = " ++ TargetMutableName ++ "; IO = IO0;",
- yes(Context))
+ predicate,
+ SetPredName,
+ [variable(X), variable(IO), variable(IO)],
+ IOSetBody
),
- IOGetClause = item_pragma(compiler(mutable_decl), IOGetForeignProc),
- add_item_clause(IOGetClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO)
+
+ add_item_clause(IOSetClause, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO)
;
IOStateInterface = no
).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.298
diff -u -r1.298 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 20 Aug 2006 08:21:16 -0000 1.298
+++ compiler/mercury_to_mercury.m 28 Aug 2006 08:43:49 -0000
@@ -508,9 +508,9 @@
maybe_output_line_number(Context, !IO),
mercury_format_mode_defn(VarSet, Name, Args, ModeDefn, Context, !IO).
mercury_output_item(UnqualifiedItemNames,
- item_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName0, TypesAndModes, WithType, WithInst, Det, _Cond, Purity,
- ClassContext),
+ item_pred_or_func(_Origin, TypeVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName0, TypesAndModes, WithType, WithInst, Det,
+ _Cond, Purity, ClassContext),
Context, !IO) :-
maybe_unqualify_sym_name(UnqualifiedItemNames, PredName0, PredName),
maybe_output_line_number(Context, !IO),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.143
diff -u -r1.143 module_qual.m
--- compiler/module_qual.m 22 Aug 2006 05:04:00 -0000 1.143
+++ compiler/module_qual.m 28 Aug 2006 08:47:01 -0000
@@ -306,7 +306,7 @@
).
collect_mq_info_2(item_module_defn(_, ModuleDefn), !Info) :-
process_module_defn(ModuleDefn, !Info).
-collect_mq_info_2(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _),
+collect_mq_info_2(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _),
!Info).
collect_mq_info_2(item_pred_or_func_mode(_, _, _, _, _, _, _), !Info).
collect_mq_info_2(item_pragma(_, _), !Info).
@@ -658,10 +658,11 @@
update_import_status(ModuleDefn, !Info, Continue).
module_qualify_item(
- item_pred_or_func(A, IVs, B, PredOrFunc, SymName, TypesAndModes0,
- WithType0, WithInst0, C, D, E, Constraints0) - Context,
- item_pred_or_func(A, IVs, B, PredOrFunc, SymName, TypesAndModes,
- WithType, WithInst, C, D, E, Constraints) - Context,
+ item_pred_or_func(Origin, A, IVs, B, PredOrFunc, SymName,
+ TypesAndModes0, WithType0, WithInst0, C, D, E, Constraints0)
+ - Context,
+ item_pred_or_func(Origin, A, IVs, B, PredOrFunc, SymName,
+ TypesAndModes, WithType, WithInst, C, D, E, Constraints) - Context,
!Info, yes, !IO) :-
list.length(TypesAndModes0, Arity),
mq_info_set_error_context(
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.399
diff -u -r1.399 modules.m
--- compiler/modules.m 22 Aug 2006 05:04:00 -0000 1.399
+++ compiler/modules.m 28 Aug 2006 08:49:09 -0000
@@ -6145,8 +6145,8 @@
%
(
list.member(Item, Items),
- Item = item_pred_or_func(_, _, _, predicate, Name, [_, _], WithType,
- _, _, _, _, _) - _,
+ Item = item_pred_or_func(_, _, _, _, predicate, Name, [_, _],
+ WithType, _, _, _, _, _) - _,
unqualify_name(Name, "main"),
% XXX We should allow `main/2' to be declared using
@@ -7289,7 +7289,8 @@
item_needs_imports(item_mode_defn(_, _, _, _, _)) = yes.
item_needs_imports(item_module_defn(_, _)) = no.
item_needs_imports(item_pragma(_, _)) = yes.
-item_needs_imports(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _)) = yes.
+item_needs_imports(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _)) =
+ yes.
item_needs_imports(item_pred_or_func_mode(_, _, _, _, _, _, _)) = yes.
item_needs_imports(Item @ item_typeclass(_, _, _, _, _, _)) =
(
@@ -7654,7 +7655,8 @@
reorderable_item(item_instance(_, _, _, _, _, _)) = yes.
reorderable_item(item_clause(_, _, _, _, _, _)) = no.
reorderable_item(item_nothing(_)) = no.
-reorderable_item(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _)) = no.
+reorderable_item(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _)) =
+ no.
reorderable_item(item_pred_or_func_mode(_, _, _, _, _, _, _)) = no.
reorderable_item(item_initialise(_, _, _)) = no.
reorderable_item(item_finalise(_, _, _)) = no.
@@ -7732,7 +7734,7 @@
chunkable_item(item_type_defn(_, _, _, _, _)) = yes.
chunkable_item(item_inst_defn(_, _, _, _, _)) = yes.
chunkable_item(item_mode_defn(_, _, _, _, _)) = yes.
-chunkable_item(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _)) = yes.
+chunkable_item(item_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _)) = yes.
chunkable_item(item_pred_or_func_mode(_, _, _, _, _, _, _)) = yes.
chunkable_item(item_promise(_, _, _, _)) = yes.
chunkable_item(item_typeclass(_, _, _, _, _, _)) = yes.
@@ -7750,8 +7752,8 @@
%
:- pred symname_ordered(item_and_context::in, sym_name::out) is semidet.
-symname_ordered(item_pred_or_func(_, _, _, _, Name, _, _, _, _, _, _, _) - _,
- Name).
+symname_ordered(item_pred_or_func(_, _, _, _, _, Name, _, _, _, _, _, _, _)
+ - _, Name).
symname_ordered(item_pred_or_func_mode(_, _, Name, _, _, _, _) - _, Name).
:- pred symname_orderable(item_and_context::in) is semidet.
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.270
diff -u -r1.270 prog_io.m
--- compiler/prog_io.m 22 Aug 2006 05:04:03 -0000 1.270
+++ compiler/prog_io.m 28 Aug 2006 08:50:45 -0000
@@ -2845,9 +2845,10 @@
get_purity(Purity, Attributes0, Attributes),
varset.coerce(VarSet0, TVarSet),
varset.coerce(VarSet0, IVarSet),
- Result0 = ok1(item_pred_or_func(TVarSet, IVarSet, ExistQVars,
- PredOrFunc, F, As, WithType, WithInst, MaybeDet, Cond,
- Purity, ClassContext)),
+ Origin = user,
+ Result0 = ok1(item_pred_or_func(Origin, TVarSet, IVarSet,
+ ExistQVars, PredOrFunc, F, As, WithType, WithInst,
+ MaybeDet, Cond, Purity, ClassContext)),
check_no_attributes(Result0, Attributes, Result)
)
;
@@ -3117,7 +3118,8 @@
(
inst_var_constraints_are_consistent_in_type_and_modes(Args)
->
- Result0 = ok1(item_pred_or_func(TVarSet, IVarSet,
+ Origin = user,
+ Result0 = ok1(item_pred_or_func(Origin, TVarSet, IVarSet,
ExistQVars, function, F, Args, no, no, MaybeDet, Cond,
Purity, ClassContext)),
check_no_attributes(Result0, Attributes, Result)
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.45
diff -u -r1.45 prog_io_goal.m
--- compiler/prog_io_goal.m 27 Jul 2006 05:01:20 -0000 1.45
+++ compiler/prog_io_goal.m 28 Aug 2006 00:36:16 -0000
@@ -5,12 +5,12 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-
+%
% File: prog_io_goal.m.
% Main authors: fjh, zs.
-
+%
% This module defines the predicates that parse goals.
-
+%
%-----------------------------------------------------------------------------%
:- module parse_tree.prog_io_goal.
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.53
diff -u -r1.53 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 22 Aug 2006 05:04:04 -0000 1.53
+++ compiler/prog_io_typeclass.m 28 Aug 2006 08:52:14 -0000
@@ -273,7 +273,7 @@
item_to_class_method(error2(Errors), _, error1(Errors)).
item_to_class_method(ok2(Item, Context), Term, Result) :-
- ( Item = item_pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L) ->
+ ( Item = item_pred_or_func(_Origin, A, B, C, D, E, F, G, H, I, J, K, L) ->
Result = ok1(method_pred_or_func(A, B, C, D, E, F, G, H, I, J, K, L,
Context))
; Item = item_pred_or_func_mode(A, B, C, D, E, F, G) ->
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.21
diff -u -r1.21 prog_item.m
--- compiler/prog_item.m 20 Aug 2006 08:21:26 -0000 1.21
+++ compiler/prog_item.m 28 Aug 2006 08:33:20 -0000
@@ -141,6 +141,7 @@
% This specifies the type of the predicate or function,
% and it may optionally also specify the mode and determinism.
; item_pred_or_func(
+ pf_origin :: item_origin,
pf_tvarset :: tvarset,
pf_instvarset :: inst_varset,
pf_existqvars :: existq_tvars,
Index: compiler/prog_mutable.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mutable.m,v
retrieving revision 1.17
diff -u -r1.17 prog_mutable.m
--- compiler/prog_mutable.m 22 Aug 2006 09:41:16 -0000 1.17
+++ compiler/prog_mutable.m 28 Aug 2006 08:58:54 -0000
@@ -60,56 +60,69 @@
% [will_not_call_mercury],
% "
% #ifdef MR_THREAD_SAFE
-% pthread_init_mutex(&mutable_<varname>, MR_MUTEX_ATTR);
+% pthread_init_mutex(&mutable_<varname>_lock, MR_MUTEX_ATTR);
% #endif
% ").
%
-% :- semipure pred get_<varname>(<vartype>::out(<varinst>)) is det.
+% Operations on mutables are defined in terms of the following four
+% predicates. Note that they are all marked `thread_safe' in order to
+% avoid having to acquire the global lock.
+%
+% :- impure pred unsafe_set_<varname>(<vartype>::in(<varinst>)) is det.
% :- pragma foreign_proc("C",
-% get_<varname>(X::out(<varinst>)),
-% [promise_semipure, will_not_call_mercury],
+% unsafe_set_<varname)(X::in(<varinst>)),
+% [will_not_call_mercury, thread_safe],
% "
-% X = mutable_<varname>;
+% mutable_<varname> = X;
% ").
-%
-% :- impure pred set_<varname>(<vartype>::in(<varinst>)) is det.
+%
+% :- semipure pred unsafe_get_<varname>(<vartype>::out(<varinst>)) is det.
% :- pragma foreign_proc("C",
-% set_<varname>(X::in(<varinst>)),
-% [will_not_call_mercury],
+% unsafe_get_varname(X::in(<varinst>)),
+% [promise_semipure, will_not_all_mercury, thread_safe],
% "
-% MR_trail_current_value(&mutable_<varname>);
-% mutable_<varname> = X;
+% X = mutable_<varname>;
+% ").
+%
+% :- impure lock_<varname> is det.
+% :- pramga foreign_proc("C",
+% lock_<varname>,
+% [will_not_call_mercury, promise_pure],
+% "
+% #ifdef MR_THREAD_SAFE
+% MR_LOCK(&mutable_<varname>_lock, \"lock_<varname>/0\");
+% #endif
% ").
%
-% NOTE: mutables *are* trailed by default. The `untrailed' attribute just
-% causes the call to MR_trail_current_value to be omitted.
+% :- impure unlock_<varname> is det.
+% :- pramga foreign_proc("C",
+% unlock_<varname>,
+% [will_not_call_mercury, promise_pure],
+% "
+% #ifdef MR_THREAD_SAFE
+% MR_UNLOCK(&mutable_<varname>_lock, \"unlock_<varname>/0\");
+% #endif
+% ").
%
-% If the `attach_to_io_state' attribute is specified we also generate:
+% The other operations are all defined in Mercury using the above predicates:
%
-% :- pred get_varname(<vartype>::out(<varinst>), io::di, io::uo) is det.
-% :- pred set_varname(<vartype>::in(<varinst>), io::di, io::uo) is det.
+% :- impure pred set_<varname>(<vartype>::in(<varinst>)) is det.
%
-% :- pragma foreign_proc("C",
-% get_varname(X::out(<varinst), IO0::di, IO::uo),
-% [promise_pure, will_not_call_mercury, tabled_for_io],
-% "
-% X = mutable_<varname>;
-% IO = IO0;
-% ").
-%
-% :- pragma foreign_proc("C",
-% set_varname(X::in(<varinst>), IO0::di, IO::uo),
-% [promise_pure, will_not_call_mercury, tabled_for_io],
-% "
-% mutable_<varname> = X;
-% IO = IO0;
-% ").
+% set_<varname>(X) :-
+% impure lock_<varname>,
+% impure unsafe_set_<varname>(X),
+% impure unlock_<varname>.
+%
+% :- semipure pred get_<varname>(<vartype>::out(<varinst>)) is det.
%
-% NOTE: we could implement the above in terms of the impure get and set
-% predicates. The reason we don't is so that we can use I/O
-% tabling.
-% XXX If tabling of impure actions is ever implemented we should
-% revisit this.
+% get_<varname>(X) :-
+% promise_semipure (
+% impure lock_<varname>
+% semipure unsafe_get_<varname>(X),
+% impure unlock_<varname>
+% ).
+%
+% etc.
%
% For constant mutables the transformation is:
%
@@ -160,6 +173,13 @@
%-----------------------------------------------------------------------------%
+ % Create premode declarations for the four primitive operations.
+ %
+:- func unsafe_get_pred_decl(module_name, string, mer_type, mer_inst) = item.
+:- func unsafe_set_pred_decl(module_name, string, mer_type, mer_inst) = item.
+:- func lock_pred_decl(module_name, string) = item.
+:- func unlock_pred_decl(module_name, string) = item.
+
% Create a predmode declaration for the semipure mutable get predicate.
% (This is the default get predicate.)
%
@@ -201,6 +221,13 @@
%
:- func mutable_init_mutex_pred_decl(module_name, string) = item.
+ % Names of the primtive operations.
+ %
+:- func mutable_lock_pred_sym_name(sym_name, string) = sym_name.
+:- func mutable_unlock_pred_sym_name(sym_name, string) = sym_name.
+:- func mutable_unsafe_get_pred_sym_name(sym_name, string) = sym_name.
+:- func mutable_unsafe_set_pred_sym_name(sym_name, string) = sym_name.
+
:- func mutable_get_pred_sym_name(sym_name, string) = sym_name.
:- func mutable_set_pred_sym_name(sym_name, string) = sym_name.
@@ -249,13 +276,74 @@
:- import_module varset.
%-----------------------------------------------------------------------------%
+%
+% Predmode declarations for primitive operations
+%
+
+unsafe_get_pred_decl(ModuleName, Name, Type, Inst) = UnsafeGetPredDecl :-
+ VarSet = varset.init,
+ InstVarSet = varset.init,
+ ExistQVars = [],
+ Constraints = constraints([], []),
+ Origin = compiler(mutable_decl),
+ UnsafeGetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet,
+ ExistQVars,
+ predicate,
+ mutable_unsafe_get_pred_sym_name(ModuleName, Name),
+ [type_and_mode(Type, out_mode(Inst))],
+ no /* with_type */, no /* with_inst */, yes(detism_det),
+ cond_true /* condition */, purity_semipure, Constraints).
+
+unsafe_set_pred_decl(ModuleName, Name, Type, Inst) = UnsafeSetPredDecl :-
+ VarSet = varset.init,
+ InstVarSet = varset.init,
+ ExistQVars = [],
+ Constraints = constraints([], []),
+ Origin = compiler(mutable_decl),
+ UnsafeSetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet,
+ ExistQVars,
+ predicate,
+ mutable_unsafe_set_pred_sym_name(ModuleName, Name),
+ [type_and_mode(Type, in_mode(Inst))],
+ no /* with_type */, no /* with_inst */, yes(detism_det),
+ cond_true /* condition */, purity_impure, Constraints).
+
+lock_pred_decl(ModuleName, Name) = LockPredDecl :-
+ VarSet = varset.init,
+ InstVarSet = varset.init,
+ ExistQVars = [],
+ Constraints = constraints([], []),
+ Origin = compiler(mutable_decl),
+ LockPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
+ mutable_lock_pred_sym_name(ModuleName, Name),
+ [],
+ no /* with_type */, no /* with_inst */, yes(detism_det),
+ cond_true /* condition */, purity_impure, Constraints).
+
+unlock_pred_decl(ModuleName, Name) = UnlockPredDecl :-
+ VarSet = varset.init,
+ InstVarSet = varset.init,
+ ExistQVars = [],
+ Constraints = constraints([], []),
+ Origin = compiler(mutable_decl),
+ UnlockPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
+ mutable_unlock_pred_sym_name(ModuleName, Name),
+ [],
+ no /* with_type */, no /* with_inst */, yes(detism_det),
+ cond_true /* condition */, purity_impure, Constraints).
+
+%-----------------------------------------------------------------------------%
std_get_pred_decl(ModuleName, Name, Type, Inst) = GetPredDecl :-
VarSet = varset.init,
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- GetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ GetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_get_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, out_mode(Inst))],
no /* with_type */, no /* with_inst */, yes(detism_det),
@@ -266,7 +354,9 @@
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- SetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ SetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_set_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, in_mode(Inst))],
no /* with_type */, no /* with_inst */, yes(detism_det),
@@ -277,7 +367,9 @@
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- GetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ GetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_get_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, out_mode(Inst))],
no /* with_type */, no /* with_inst */, yes(detism_det),
@@ -288,7 +380,9 @@
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- SetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ SetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_secret_set_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, in_mode(Inst))],
no /* with_type */, no /* with_inst */, yes(detism_det),
@@ -299,7 +393,9 @@
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- GetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ GetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_get_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, out_mode(Inst)),
type_and_mode(io_state_type, di_mode),
@@ -312,7 +408,9 @@
InstVarSet = varset.init,
ExistQVars = [],
Constraints = constraints([], []),
- SetPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
+ Origin = compiler(mutable_decl),
+ SetPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate,
mutable_set_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, in_mode(Inst)),
type_and_mode(io_state_type, di_mode),
@@ -329,8 +427,9 @@
WithType = no,
WithInst = no,
Condition = cond_true,
- InitPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
- mutable_init_pred_sym_name(ModuleName, Name), ArgDecls,
+ Origin = compiler(mutable_decl),
+ InitPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet, ExistQVars,
+ predicate, mutable_init_pred_sym_name(ModuleName, Name), ArgDecls,
WithType, WithInst, yes(detism_det), Condition,
purity_impure, Constraints).
@@ -343,13 +442,27 @@
WithType = no,
WithInst = no,
Condition = cond_true,
- InitMutexPredDecl = item_pred_or_func(VarSet, InstVarSet, ExistQVars,
- predicate, mutable_init_mutex_pred_sym_name(ModuleName, Name),
+ Origin = compiler(mutable_decl),
+ InitMutexPredDecl = item_pred_or_func(Origin, VarSet, InstVarSet,
+ ExistQVars, predicate,
+ mutable_init_mutex_pred_sym_name(ModuleName, Name),
ArgDecls, WithType, WithInst, yes(detism_det), Condition,
purity_impure, Constraints).
%-----------------------------------------------------------------------------%
+mutable_lock_pred_sym_name(ModuleName, Name) =
+ qualified(ModuleName, "lock_" ++ Name).
+
+mutable_unlock_pred_sym_name(ModuleName, Name) =
+ qualified(ModuleName, "unlock_" ++ Name).
+
+mutable_unsafe_get_pred_sym_name(ModuleName, Name) =
+ qualified(ModuleName, "unsafe_get_" ++ Name).
+
+mutable_unsafe_set_pred_sym_name(ModuleName, Name) =
+ qualified(ModuleName, "unsafe_set_" ++ Name).
+
mutable_get_pred_sym_name(ModuleName, Name) =
qualified(ModuleName, "get_" ++ Name).
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.92
diff -u -r1.92 prog_util.m
--- compiler/prog_util.m 22 Aug 2006 05:04:05 -0000 1.92
+++ compiler/prog_util.m 25 Aug 2006 08:21:46 -0000
@@ -5,13 +5,13 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-
+%
% File: prog_util.
% Main author: fjh.
-
+%
% Various utility predicates acting on the parse tree data structure defined
% in prog_data.m and prog_item.m
-
+%
%-----------------------------------------------------------------------------%
:- module parse_tree.prog_util.
@@ -268,6 +268,12 @@
term(T).
%-----------------------------------------------------------------------------%
+
+ % Convert a list of goals into a conjunction.
+ %
+:- func goal_list_to_conj(prog_context, list(goal)) = goal.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -807,6 +813,18 @@
%-----------------------------------------------------------------------------%
+goal_list_to_conj(Context, []) = true_expr - Context.
+goal_list_to_conj(Context, [Goal | Goals]) =
+ goal_list_to_conj_2(Context, Goal, Goals).
+
+:- func goal_list_to_conj_2(prog_context, goal, list(goal)) = goal.
+
+goal_list_to_conj_2(_, Goal, []) = Goal.
+goal_list_to_conj_2(Context, Goal0, [Goal1 | Goals]) =
+ conj_expr(Goal0, goal_list_to_conj_2(Context, Goal1, Goals)) - Context.
+
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "prog_util.m".
Index: compiler/recompilation.check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.32
diff -u -r1.32 recompilation.check.m
--- compiler/recompilation.check.m 20 Aug 2006 08:21:28 -0000 1.32
+++ compiler/recompilation.check.m 28 Aug 2006 08:59:20 -0000
@@ -880,7 +880,7 @@
true
).
check_for_ambiguities(NeedQualifier, OldTimestamp, VersionNumbers,
- item_pred_or_func(_, _, _, PredOrFunc, Name, Args,
+ item_pred_or_func(_, _, _, _, PredOrFunc, Name, Args,
WithType, _, _, _, _, _) - _, !Info) :-
check_for_pred_or_func_item_ambiguity(no, NeedQualifier, OldTimestamp,
VersionNumbers, PredOrFunc, Name, Args, WithType, !Info).
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.52
diff -u -r1.52 recompilation.version.m
--- compiler/recompilation.version.m 22 Aug 2006 05:04:06 -0000 1.52
+++ compiler/recompilation.version.m 28 Aug 2006 09:01:09 -0000
@@ -397,9 +397,9 @@
% That needs to be done here as well the item list read from the interface
% file will match the item list generated here.
(
- Item = item_pred_or_func(TVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, WithType, WithInst, Det, Cond, Purity,
- ClassContext),
+ Item = item_pred_or_func(Origin, TVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes, WithType, WithInst, Det,
+ Cond, Purity, ClassContext),
split_types_and_modes(TypesAndModes, Types, MaybeModes),
MaybeModes = yes(Modes),
( Modes = [_ | _]
@@ -408,7 +408,7 @@
->
TypesWithoutModes = list.map((func(Type) = type_only(Type)), Types),
varset.init(EmptyInstVarSet),
- PredOrFuncItem = item_pred_or_func(TVarSet, EmptyInstVarSet,
+ PredOrFuncItem = item_pred_or_func(Origin, TVarSet, EmptyInstVarSet,
ExistQVars, PredOrFunc, PredName, TypesWithoutModes, WithType,
no, no, Cond, Purity, ClassContext),
(
@@ -507,7 +507,7 @@
list.length(Params, Arity).
item_to_item_id_2(item_module_defn(_, _), no).
item_to_item_id_2(Item, yes(item_id(ItemType, item_name(SymName, Arity)))) :-
- Item = item_pred_or_func(_, _, _, PredOrFunc, SymName, TypesAndModes,
+ Item = item_pred_or_func(_, _, _, _, PredOrFunc, SymName, TypesAndModes,
WithType, _, _, _, _, _),
% For predicates or functions defined using `with_type` annotations
% the arity here won't be correct, but equiv_type.m will record
@@ -721,11 +721,11 @@
( Item2 = item_mutable(A, B, C, D, E, F) -> yes ; no ).
item_is_unchanged(Item1, Item2) = Result :-
- Item1 = item_pred_or_func(TVarSet1, _, ExistQVars1, PredOrFunc,
+ Item1 = item_pred_or_func(_, TVarSet1, _, ExistQVars1, PredOrFunc,
Name, TypesAndModes1, WithType1, _,
Det1, Cond, Purity, Constraints1),
(
- Item2 = item_pred_or_func(TVarSet2, _, ExistQVars2,
+ Item2 = item_pred_or_func(_, TVarSet2, _, ExistQVars2,
PredOrFunc, Name, TypesAndModes2, WithType2,
_, Det2, Cond, Purity, Constraints2),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.118
diff -u -r1.118 table_gen.m
--- compiler/table_gen.m 22 Aug 2006 05:04:09 -0000 1.118
+++ compiler/table_gen.m 28 Aug 2006 09:17:44 -0000
@@ -1931,6 +1931,7 @@
keep_marker(marker_calls_are_fully_qualified) = yes.
keep_marker(marker_mode_check_clauses) = yes.
keep_marker(marker_may_have_parallel_conj) = yes.
+keep_marker(marker_mutable_access_pred) = yes.
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list