[m-rev.] for review: software transactional memory language extension
Leon Ilario MIKA
lmika at students.csse.unimelb.edu.au
Tue Oct 9 15:24:42 AEST 2007
Estimated hours taken: 198
Addition of Software Transactional Memory constructs into the language.
This includes the addition of the "atomic_goal" HLDS goal expression, and the
"atomic" and "or_else" operators into the parse tree. It also includes the
addition of another HLDS -> HLDS transformation to expand out atomic_goals
into standard predicates (Stage 113).
Also, fixed some bugs in "library/stm_builtin.m" and "runtime/mercury_stm.c"
and "runtime/mercury_stm.h" and began work on the reference manual entry for
Software Transactional Memory.
Currently, single atomic transactions are supported. The transactions can
rollback if invalid and can block when retried. Only support for the
High Level C backend has been fully implemented (transactions do work in
the "asm_fast" grades but raise an exception when attempting to retry).
Also, the modules "stm_builtin", "exception" and "univ" must be explicitly
imported if the "atomic" scope is to be used.
compiler/add_clause.m:
Added case for transforming atomic terms into "atomic_goal" HLDS goals.
No support for state variables has been added yet.
compiler/det_analysis.m:
Added code the determine the determinism of atomic_goals. Currently,
the inner goals of atomic scopes can only be "det" or "cc_multi" or
"erroneous" for exceptions or the retry call.
compiler/det_report.m:
Added code to diagnose the determinism discrepency of the atomic_goals.
compiler/goal_form.m:
Added code to support the atomic_goal in switch statements over the
HLDS goal expression.
compiler/goal_path.m:
Added code to support the atomic_goal. Also added new slots
"atomic_goal_main" and "atomic_goal_orelse".
compiler/goal_util.m:
Added code to support the atomic_goal in switch statements over the
HLDS goal expression.
compiler/hlds_goal.m:
Added the "atomic_goal" expression into the list of HLDS goal
expressions. Also added the "atomic_goal_type" type to identify the
kind of atomic goal an atomic_goal is. Also added cases for switch
statements over the HLDS expression.
compiler/hlds_module.m:
Added predicates to count the number of atomic scopes exist in a
particular context.
compiler/hlds_out.m:
Added code to display atomic_goals.
compiler/hlds_pred.m:
Added a new predicate transform origin reason for STM expansion.
compiler/layout_out.m:
Added a new predicate transform origin reason for STM expansion.
compiler/mercury_compile.m:
Added a new pass over the module which expands atomic_goals into new
predicates.
compiler/mercury_to_mercury.m:
Added code to display atomic goals in the parse tree.
compiler/middle_rec.m:
Added code to handle atomic_goals in "contains_only_builtins_expr".
compiler/mode_constraint_robdd.m:
Added code to display the "step_atomic_main" and "step_atomic_orelse"
goal paths.
compiler/mode_errors.m:
compiler/mode_info.m:
Added new reason to lock variables in "modes.m". Not used yet for
reasons explained in "modes.m"
compiler/modes.m:
Added code to check the mode of the atomic_goal. Exact operations are
documented in the mode-checking case for atomic goals. Currently,
the requirements of the inner goals of atomic goals are similar to
disjunctions.
compiler/prog_data.m:
Added the type atomic_component_state which stores the "outer" and
"inner" variables of the atomic goal.
compiler/prog_io_goal.m:
Added code to parse the atomic scope and its parameters. Also added
code to parse the "or_else" operator.
compiler/prog_item.m:
Added atomic expressions into the parse tree goals.
compiler/prog_type.m:
Added "stm_builtin.stm" type to the list of standard types.
compiler/purity.m:
Added code to calculate the purity of atomic goals.
compiler/quantification.m:
Added code to calculate the quantification of atomic goals. Currently,
atomic goals are quantified in a similar way to disjunctions.
compiler/simplify.m:
Added case for atomic goals. Currently not simplifying the inner
goals as code to fixup outer and inner variables have not been
written yet.
compiler/stm_expand.m:
New HLDS -> HLDS transform module. This module will expand out all
"atomic_goals" into separate predicates which will perform the
required behaviour of Software Transactional Memory. This will
expand atomic_goals in an entire module or an individual predicate
and is designed to be called by "mercury_compile.m" durring the
HLDS -> HLDS transform stage of compilation.
compiler/smm_common.m:
Added code to display the "step_atomic_main" and "stem_atomic_orelse"
goal paths.
compiler/transform_hlds.m:
Added import to "stm_expand" module.
compiler/typecheck.m:
Added code to typecheck atomic goals as well as code to check if the
non-locals in the atomic goal do not include the outer variables of
the atomic scope. Reasons why this code is in this module instead
of quantification are made in the source file.
Also added a new typecheck predicate which checks whether or not
a variable is either one of two types. It first checks if the variable
is of TypeA. If the variable cannot be unified with TypeA, it
attempts to unify it with TypeB. If that also fails, it raises an
error.
compiler/typecheck_errors.m:
Added code to report an error if a variable is not of one of two
types. Used by the typecheck predicate described above to display
the errors.
compiler/assertions.m:
compiler/delay_partial_inst.m:
compiler/dependency_graph.m
compiler/equiv_type_hlds.m:
compiler/format_call.m:
compiler/intermod.m:
compiler/lambda.m:
compiler/make_hlds_warn.m:
compiler/mode_constraints.m:
compiler/mode_ordering.m:
compiler/mode_util.m:
compiler/module_qual.m:
compiler/ordering_mode_constraints.m:
compiler/polymorphism.m:
compiler/post_typecheck.m:
compiler/prog_util.m:
compiler/prop_mode_constraints.m:
compiler/stratify.m:
compiler/switch_detection.m:
compiler/unique_modes.m:
Added code to simply traverse the inner goals of the atomic_goal.
(cases marked with "XXX STM" may be incomplete or need to be checked).
compiler/build_mode_constraints.m:
compiler/cse_detection.m:
compiler/unused_imports.m:
Modules in which handling of atomic_goals is not yet complete.
compiler/add_heap_ops.m:
compiler/add_trail_ops.m:
compiler/bytecode_gen.m:
compiler/closure_analysis.m:
compiler/code_gen.m:
compiler/code_util.m:
compiler/constraints.m:
compiler/dead_proc_elim.m:
compiler/deep_profiling.m:
compiler/deforest.m:
compiler/delay_construct.m:
compiler/dep_par_conj.m:
compiler/distance_granularity.m:
compiler/erl_code_gen.m:
compiler/exception_analysis.m:
compiler/follow_code.m:
compiler/follow_vars.m:
compiler/granularity.m:
compiler/hhf.m:
compiler/higher_order.m:
compiler/implicit_parallelism.m:
compiler/inlining.m:
compiler/interval.m:
compiler/lco.m:
compiler/live_vars.m:
compiler/liveness.m:
compiler/loop_inv.m:
compiler/make_static_terms.m:
compiler/ml_code_gen.m:
compiler/pd_const.m:
compiler/prog_rep.m:
compiler/rbmm.actual_region_arguments.m:
compiler/rbmm.add_rbmm_goal_infos.m:
compiler/rbmm.condition_renaming.m:
compiler/rbmm.execution_path.m:
compiler/rbmm.points_to_analysis.m:
compiler/rbmm.region_transformation.m:
compiler/saved_vars.m:
compiler/size_prof.m:
compiler/store_alloc.m:
compiler/structure_reuse.direct.choose_reuse.m:
compiler/structure_reuse.direct.detect_garbage.m:
compiler/structure_reuse.indirect.m:
compiler/structure_reuse.lbu.m:
compiler/structure_reuse.versions.m:
compiler/structure_sharing.analysis.m:
compiler/tabling_analysis.m:
compiler/term_constr_build.m:
compiler/term_pass1.m:
compiler/term_traversal.m:
compiler/trailing_analysis.m:
compiler/tupling.m:
compiler/unneeded_code.m:
compiler/untupling.m:
compiler/unused_args.m:
Added calls to "unexpected" indicating that atomic_goals should be
expanded out at that stage.
doc/reference_manual.texi:
Began writing a section documenting how to use the Software
Transactional Memory constructs in programs. Currently this section
is listed in the section of Melbourne University Mercury Extensions
and explains how to use the atomic scope and a brief explaination
about transaction variables. Still a work in progress.
library/ops.m:
Added the "atomic" operator as a binary posfix operator and "or_else"
as a binary infix operator.
library/stm_builtin.m:
Fixed a number of bugs. Addition of closure versions of atomic
goals and "or_else" by juliensf also included.
mdbcomp/program_representation.m:
Addition of the "stem_atomic_main" and "step_atomic_orelse" goal
paths.
runtime/mercury_conf_params.h:
Addition of the flag "MR_STM_PROFILE" which, when defined, will
perform and display performance and profiling information which
may be useful for evaluation purposes. Not used at the moment.
runtime/mercury_stm.c:
Fixed up a few bugs and added a few more tracing code. Also fully
implemented wait queues, merging of transaction logs and blocking and
rescheduling of threads (for the "hlc" at the moment).
runtime/mercury_stm.h:
Changed declarations of condition variables from POSIX condition
variables to Mercury condition variables in "mercury_thread.h".
Also added prototypes for wait queues, merging of transaction logs
and blocking/rescheduling of threads.
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.45
diff -u -r1.45 add_clause.m
--- compiler/add_clause.m 28 Sep 2007 03:17:11 -0000 1.45
+++ compiler/add_clause.m 9 Oct 2007 02:45:53 -0000
@@ -677,6 +677,78 @@
transform_promise_eqv_goal(Vars0, DotSVars0, ColonSVars0,
Context, Renaming, Vars, Goal0, Goal, GoalInfo, NumAdded,
!VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
+transform_goal_2(atomic_expr(Outer0, Inner0, MaybeVars0, MainGoalExpr0,
+ OrElseGoalsExprs), Context, Renaming, Goal, !:NumAdded, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
+ rename_atomic_component_vars(Inner0, Renaming, Inner),
+ rename_atomic_component_vars(Outer0, Renaming, Outer),
+ (
+ Outer0 = atomic_state_var(_),
+ sorry(this_file, "transform_goal_2: atomic_state_var")
+ % XXX Need to implement
+ ;
+ Outer0 = atomic_var_pair(OuterDI, OuterUO)
+ ),
+
+ (
+ Inner0 = atomic_state_var(_),
+ sorry(this_file, "transform_goal_2: atomic_state_var")
+ % XXX Need to implement
+ ;
+ Inner0 = atomic_var_pair(InnerDI, InnerUO)
+ ),
+
+ (
+ MaybeVars0 = no,
+ MaybeVars = no
+ ;
+ MaybeVars0 = yes(OutVars0),
+ rename_var_list(need_not_rename, Renaming, OutVars0, OutVars),
+ MaybeVars = yes(OutVars)
+ ),
+
+ % TODO: Need to extend this to handle stm -> stm as well.
+ IOToStmName = qualified(mercury_stm_builtin_module,
+ "stm_from_outer_to_inner_io"),
+ StmToIOName = qualified(mercury_stm_builtin_module,
+ "stm_from_inner_to_outer_io"),
+
+ OuterDIVar = term.variable(OuterDI, Context),
+ OuterUOVar = term.variable(OuterUO, Context),
+ InnerDIVar = term.variable(InnerDI, Context),
+ InnerUOVar = term.variable(InnerUO, Context),
+
+ Purity = purity_pure,
+
+ PreGoal = call_expr(IOToStmName, [OuterDIVar, InnerDIVar],
+ Purity) - Context,
+ PostGoal = call_expr(StmToIOName, [InnerUOVar, OuterUOVar],
+ Purity) - Context,
+
+ MainGoalExpr = goal_list_to_conj(Context,
+ [PreGoal, MainGoalExpr0, PostGoal]),
+
+ transform_goal(MainGoalExpr, Renaming, MainGoal,
+ !:NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
+
+ (
+ OrElseGoalsExprs = [],
+ OrElseGoals = [],
+ OrElseNumAdded = 0
+ ;
+ OrElseGoalsExprs = [_ | _],
+ % TODO: Also do the same for each or_else branch.
+ transform_orelse_goals(OrElseGoalsExprs, PreGoal, PostGoal,
+ Renaming, OrElseGoals, 0,
+ OrElseNumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
+ ),
+
+ !:NumAdded = !.NumAdded + OrElseNumAdded + 1,
+
+ GoalExpr = atomic_goal(unknown_atomic_goal_type, Outer, Inner,
+ MaybeVars, MainGoal, OrElseGoals),
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ goal_info_init(GoalInfo).
transform_goal_2(
trace_expr(MaybeCompileTime, MaybeRunTime, MaybeIO, Mutables, Goal0),
Context, Renaming, hlds_goal(scope(Reason, Goal), GoalInfo), NumAdded,
@@ -1253,6 +1325,47 @@
Disj = [{Goal1, SInfo1} | Disj0]
).
+:- pred rename_atomic_component_vars(atomic_component_state::in,
+ prog_var_renaming::in, atomic_component_state::out) is det.
+
+rename_atomic_component_vars(AtomicCompState0, Renaming, AtomicCompState) :-
+ (
+ AtomicCompState0 = atomic_state_var(Var0),
+ rename_var(need_not_rename, Renaming, Var0, Var),
+ AtomicCompState = atomic_state_var(Var)
+ ;
+ AtomicCompState0 = atomic_var_pair(VarDI0, VarUO0),
+ rename_var(need_not_rename, Renaming, VarDI0, VarDI),
+ rename_var(need_not_rename, Renaming, VarUO0, VarUO),
+ AtomicCompState = atomic_var_pair(VarDI, VarUO)
+ ).
+
+:- pred transform_orelse_goals(goals::in, goal::in, goal::in,
+ prog_var_renaming::in, hlds_goals::out, num_added_goals::in,
+ num_added_goals::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+transform_orelse_goals([], _, _, _, [], NumAdded, NumAdded, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !Specs).
+transform_orelse_goals([Goal | Goals], PreGoal, PostGoal, Renaming,
+ [HldsGoal | HldsGoals], NumAdded0, NumAdded, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !Specs) :-
+ Goal = (_ - Context),
+
+ NewGoal = goal_list_to_conj(Context,
+ [PreGoal, Goal, PostGoal]),
+
+ NewGoal = (GoalExpr - _),
+
+ transform_goal_2(GoalExpr, Context, Renaming, HldsGoal, NumAddedGoal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
+
+ NumAdded1 = NumAdded0 + NumAddedGoal,
+ transform_orelse_goals(Goals, PreGoal, PostGoal, Renaming, HldsGoals,
+ NumAdded1, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
+
%----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/add_heap_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_heap_ops.m,v
retrieving revision 1.35
diff -u -r1.35 add_heap_ops.m
--- compiler/add_heap_ops.m 7 Aug 2007 07:09:46 -0000 1.35
+++ compiler/add_heap_ops.m 9 Oct 2007 02:59:29 -0000
@@ -139,6 +139,10 @@
GoalExpr = disj(Goals)
).
+goal_expr_add_heap_ops(atomic_goal(_, _, _, _, _, _),
+ _GI, _NewGoal, !Info) :-
+ unexpected(this_file, "goal_expr_add_heap_ops: atomic_goal").
+
goal_expr_add_heap_ops(switch(Var, CanFail, Cases0), GI,
hlds_goal(switch(Var, CanFail, Cases), GI), !Info) :-
cases_add_heap_ops(Cases0, Cases, !Info).
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.47
diff -u -r1.47 add_trail_ops.m
--- compiler/add_trail_ops.m 7 Aug 2007 07:09:46 -0000 1.47
+++ compiler/add_trail_ops.m 9 Oct 2007 02:59:36 -0000
@@ -313,6 +313,10 @@
goal_expr_add_trail_ops(GoalExpr @ unify(_, _, _, _, _), GI,
hlds_goal(GoalExpr, GI), !Info).
+goal_expr_add_trail_ops(atomic_goal(_, _, _, _, _, _),
+ _GI, _NewGoal, !Info) :-
+ unexpected(this_file, "goal_expr_add_trail_ops: atomic_goal").
+
goal_expr_add_trail_ops(PragmaForeign, GoalInfo, Goal, !Info) :-
PragmaForeign = call_foreign_proc(_, _, _, _, _, _, Impl),
(
Index: compiler/assertion.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/assertion.m,v
retrieving revision 1.58
diff -u -r1.58 assertion.m
--- compiler/assertion.m 7 Aug 2007 07:09:46 -0000 1.58
+++ compiler/assertion.m 1 Oct 2007 02:44:08 -0000
@@ -701,6 +701,13 @@
normalise_goal(Then0, Then),
normalise_goal(Else0, Else),
GoalExpr = if_then_else(Vars, Cond, Then, Else)
+ ; % XXX STM - To Check
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal0, OrElseAlternatives0),
+ normalise_goal(MainGoal0, MainGoal),
+ normalise_goals(OrElseAlternatives0, OrElseAlternatives),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseAlternatives)
;
GoalExpr0 = shorthand(ShortHandGoal0),
normalise_goal_shorthand(ShortHandGoal0, ShortHandGoal),
Index: compiler/build_mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/build_mode_constraints.m,v
retrieving revision 1.27
diff -u -r1.27 build_mode_constraints.m
--- compiler/build_mode_constraints.m 7 Aug 2007 07:09:46 -0000 1.27
+++ compiler/build_mode_constraints.m 1 Oct 2007 02:44:08 -0000
@@ -330,6 +330,10 @@
Goals = [Cond, Then, Else],
list.foldl(add_mc_vars_for_goal(PredId, ProgVarset), Goals, !VarInfo)
;
+ % XXX STM - To Check and finish
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ sorry(this_file, "add_mc_vars_for_goal: atomic_goal")
+ ;
GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
;
GoalExpr = shorthand(_ShorthandGoalExpr)
@@ -480,6 +484,12 @@
Details = cast(_)
).
+% XXX STM - To finish
+add_goal_expr_constraints(_ModuleInfo, _ProgVarset, _PredId,
+ atomic_goal(_, _, _, _, _, _), _Context, _GoalPath,
+ _Nonlocals, !VarInfo, !Constraints) :-
+ sorry(this_file, "atomic_goal").
+
add_goal_expr_constraints(_ModuleInfo, _ProgVarset, _PredId,
switch(_, _, _), _Context, _GoalPath, _Nonlocals, _, _, _, _) :-
unexpected(this_file, "switch").
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.115
diff -u -r1.115 bytecode_gen.m
--- compiler/bytecode_gen.m 11 Sep 2007 03:12:27 -0000 1.115
+++ compiler/bytecode_gen.m 9 Oct 2007 03:00:39 -0000
@@ -299,6 +299,9 @@
GoalExpr = call_foreign_proc(_, _, _, _, _, _, _),
Code = node([byte_not_supported])
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ sorry(this_file, "goal_expr: unexpecet atomic_goal")
+ ;
GoalExpr = shorthand(_),
% these should have been expanded out by now
unexpected(this_file, "goal_expr: unexpected shorthand")
Index: compiler/closure_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/closure_analysis.m,v
retrieving revision 1.15
diff -u -r1.15 closure_analysis.m
--- compiler/closure_analysis.m 7 Aug 2007 07:09:47 -0000 1.15
+++ compiler/closure_analysis.m 9 Oct 2007 03:00:53 -0000
@@ -369,6 +369,10 @@
list.filter_map(ForeignHOArgs, Args, OutputForeignHOArgs),
svmap.det_insert_from_assoc_list(OutputForeignHOArgs, !ClosureInfo),
Goal = hlds_goal(GoalExpr, GoalInfo).
+
+process_goal(_, _, hlds_goal(atomic_goal(_, _, _, _, _, _), _), _, _, _) :-
+ unexpected(this_file, "atomic_goal/4 goal durring closure analysis.").
+
process_goal(_, _, hlds_goal(shorthand(_), _), _, _, _) :-
unexpected(this_file, "shorthand/1 goal during closure analysis.").
@@ -453,6 +457,8 @@
dump_closure_info_expr(_, call_foreign_proc(_, _, _, _, _, _, _), _, !IO).
dump_closure_info_expr(Varset, disj(Goals), _, !IO) :-
list.foldl(dump_closure_info(Varset), Goals, !IO).
+dump_closure_info_expr(_, atomic_goal(_, _, _, _, _, _), _, _, _) :-
+ unexpected(this_file, "atomic goal encountered.\n").
dump_closure_info_expr(_, shorthand(_), _, _, _) :-
unexpected(this_file, "shorthand goal encountered.\n").
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.173
diff -u -r1.173 code_gen.m
--- compiler/code_gen.m 7 Aug 2007 07:09:47 -0000 1.173
+++ compiler/code_gen.m 9 Oct 2007 03:01:09 -0000
@@ -266,6 +266,10 @@
"generate_goal_2: foreign code other than C unexpected")
)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ % These should be expanded out by now.
+ unexpected(this_file, "generate_goal_2: unexpected atomic_goal")
+ ;
GoalExpr = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "generate_goal_2: unexpected shorthand")
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.180
diff -u -r1.180 code_util.m
--- compiler/code_util.m 13 Aug 2007 03:01:38 -0000 1.180
+++ compiler/code_util.m 9 Oct 2007 03:01:18 -0000
@@ -256,6 +256,9 @@
;
goal_may_alloc_temp_frame(E, May)
).
+goal_may_alloc_temp_frame_2(atomic_goal(_, _, _, _, _, _), _May) :-
+ unexpected(this_file, "goal_may_alloc_temp_frame_2: atomic_goal").
+
goal_may_alloc_temp_frame_2(shorthand(ShorthandGoal), May) :-
goal_may_alloc_temp_frame_2_shorthand(ShorthandGoal,May).
Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.86
diff -u -r1.86 constraint.m
--- compiler/constraint.m 7 Aug 2007 07:09:49 -0000 1.86
+++ compiler/constraint.m 9 Oct 2007 03:01:36 -0000
@@ -201,6 +201,9 @@
flatten_constraints(Constraints, ConstraintGoals),
FinalGoals = [hlds_goal(GoalExpr, GoalInfo) | ConstraintGoals]
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "propagate_conj_sub_goal_2: atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(this_file, "propagate_conj_sub_goal_2: shorthand")
).
@@ -817,6 +820,8 @@
strip_constraint_markers_expr(Goal) = Goal :-
Goal = unify(_, _, _, _, _).
strip_constraint_markers_expr(Goal) = Goal :-
+ Goal = atomic_goal(_, _, _, _, _, _).
+strip_constraint_markers_expr(Goal) = Goal :-
Goal = shorthand(_).
%-----------------------------------------------------------------------------%
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.110
diff -u -r1.110 cse_detection.m
--- compiler/cse_detection.m 7 Aug 2007 07:09:49 -0000 1.110
+++ compiler/cse_detection.m 1 Oct 2007 02:44:09 -0000
@@ -248,6 +248,10 @@
instmap::in, cse_info::in, cse_info::out, bool::out,
hlds_goal_expr::out) is det.
+% XXX STM - To Check and finish
+detect_cse_in_goal_2(Goal @ atomic_goal(_, _, _, _, _, _), _, _,
+ !CseInfo, no, Goal).
+
detect_cse_in_goal_2(Goal @ call_foreign_proc(_, _, _, _, _, _, _), _, _,
!CseInfo, no, Goal).
detect_cse_in_goal_2(Goal @ generic_call(_, _, _, _), _, _, !CseInfo,
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.124
diff -u -r1.124 dead_proc_elim.m
--- compiler/dead_proc_elim.m 13 Aug 2007 03:01:38 -0000 1.124
+++ compiler/dead_proc_elim.m 9 Oct 2007 03:02:05 -0000
@@ -608,6 +608,8 @@
Uni = complicated_unify(_, _, _),
unexpected(this_file, "dead_proc_examine_expr: complicated_unify")
).
+dead_proc_examine_expr(atomic_goal(_, _, _, _, _, _), _, !Queue, !Needed) :-
+ unexpected(this_file, "detect_cse_in_goal_2: unexpected atomic_goal").
dead_proc_examine_expr(shorthand(_), _, !Queue, !Needed) :-
% These should have been expanded out by now.
unexpected(this_file, "detect_cse_in_goal_2: unexpected shorthand").
@@ -1053,6 +1055,10 @@
!DeadInfo).
pre_modecheck_examine_goal_expr(unify(_, Rhs, _, _, _), !DeadInfo) :-
pre_modecheck_examine_unify_rhs(Rhs, !DeadInfo).
+pre_modecheck_examine_goal_expr(atomic_goal(_, _, _, _, _, _), !DeadInfo) :-
+ % These should have been expanded out by now.
+ unexpected(this_file,
+ "pre_modecheck_examine_goal_expr: unexpected atomic_goal").
pre_modecheck_examine_goal_expr(shorthand(_), !DeadInfo) :-
% These should have been expanded out by now.
unexpected(this_file,
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.65
diff -u -r1.65 deep_profiling.m
--- compiler/deep_profiling.m 13 Aug 2007 03:01:39 -0000 1.65
+++ compiler/deep_profiling.m 9 Oct 2007 03:02:16 -0000
@@ -283,6 +283,9 @@
Goal = Goal0,
Continue = no
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "atomic_goal in apply_tail_recursion_to_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "shorthand in apply_tail_recursion_to_goal")
).
@@ -397,6 +400,10 @@
GoalExpr = negation(Goal1),
figure_out_rec_call_numbers(Goal1, !N, !TailCallSites)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "figure_out_rec_call_numbers: unexpected atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(this_file, "shorthand in apply_tail_recursion_to_goal")
).
@@ -1048,6 +1055,10 @@
Goal = hlds_goal(scope(commit(force_pruning), InnerGoal), GoalInfo)
)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "deep_prof_transform_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file,
"deep_prof_transform_goal: shorthand should have gone by now")
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.81
diff -u -r1.81 deforest.m
--- compiler/deforest.m 7 Aug 2007 07:09:50 -0000 1.81
+++ compiler/deforest.m 9 Oct 2007 03:02:42 -0000
@@ -357,6 +357,10 @@
deforest_goal_expr(GoalExpr, GoalExpr, !GoalInfo, !PDInfo, !IO) :-
GoalExpr = unify(_, _, _, _, _).
+deforest_goal_expr(atomic_goal(_, _, _, _, _, _), _, !GoalInfo, !PDInfo, !IO) :-
+ % these should have been expanded out by now
+ unexpected(this_file, "goal: unexpected atomic_goal").
+
deforest_goal_expr(shorthand(_), _, !GoalInfo, !PDInfo, !IO) :-
% these should have been expanded out by now
unexpected(this_file, "goal: unexpected shorthand").
Index: compiler/delay_construct.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/delay_construct.m,v
retrieving revision 1.25
diff -u -r1.25 delay_construct.m
--- compiler/delay_construct.m 7 Aug 2007 07:09:50 -0000 1.25
+++ compiler/delay_construct.m 9 Oct 2007 03:02:58 -0000
@@ -162,6 +162,11 @@
),
Goal = hlds_goal(GoalExpr0, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ % These should have been expanded out by now.
+ unexpected(this_file,
+ "delay_construct_in_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "delay_construct_in_goal: unexpected shorthand")
Index: compiler/delay_partial_inst.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/delay_partial_inst.m,v
retrieving revision 1.3
diff -u -r1.3 delay_partial_inst.m
--- compiler/delay_partial_inst.m 28 Sep 2007 03:17:11 -0000 1.3
+++ compiler/delay_partial_inst.m 1 Oct 2007 02:44:09 -0000
@@ -432,6 +432,16 @@
),
Goal = Goal0
;
+ % XXX STM - To Check
+ GoalExpr0 = atomic_goal(GoalType, Inner, Outer, Vars, MainGoal0,
+ OrElseAlternatives0),
+ delay_partial_inst_in_goal(InstMap0, MainGoal0, MainGoal,
+ !.ConstructMap, _, !DelayInfo),
+ delay_partial_inst_in_goals(InstMap0, OrElseAlternatives0,
+ OrElseAlternatives, !.ConstructMap, _, !DelayInfo),
+ Goal = hlds_goal(atomic_goal(GoalType, Inner, Outer, Vars,
+ MainGoal, OrElseAlternatives), GoalInfo0)
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file,
Index: compiler/dep_par_conj.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dep_par_conj.m,v
retrieving revision 1.21
diff -u -r1.21 dep_par_conj.m
--- compiler/dep_par_conj.m 7 Aug 2007 07:09:50 -0000 1.21
+++ compiler/dep_par_conj.m 9 Oct 2007 03:03:20 -0000
@@ -493,6 +493,11 @@
),
Goal = Goal0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "atomic goal encountered during dependent parallel " ++
+ "conjunction transformation.")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file,
"shorthand goal encountered during dependent parallel " ++
@@ -820,6 +825,11 @@
insert_wait_before_goal(ModuleInfo, FutureMap, ConsumedVar,
Goal0, Goal, !VarSet, !VarTypes)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "atomic_goal goal encountered during dependent parallel " ++
+ "conjunction transformation.")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file,
"shorthand goal encountered during dependent parallel " ++
@@ -969,6 +979,11 @@
insert_signal_after_goal(ModuleInfo, FutureMap, ProducedVar,
Goal0, Goal, !VarSet, !VarTypes)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "atomic goal encountered during dependent parallel " ++
+ "conjunction transformation.")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file,
"shorthand goal encountered during dependent parallel " ++
@@ -1100,6 +1115,11 @@
),
Goal = Goal0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "atomic goal encountered during dependent parallel " ++
+ "conjunction transformation.")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file,
"shorthand goal encountered during dependent parallel " ++
@@ -1498,6 +1518,7 @@
; GoalExpr0 = plain_call(_, _, _, _, _, _)
; GoalExpr0 = generic_call(_, _, _, _)
; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
+ ; GoalExpr0 = atomic_goal(_, _, _, _, _, _)
; GoalExpr0 = shorthand(_)
),
Goal = Goal0
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.96
diff -u -r1.96 dependency_graph.m
--- compiler/dependency_graph.m 7 Sep 2007 15:08:16 -0000 1.96
+++ compiler/dependency_graph.m 1 Oct 2007 02:44:09 -0000
@@ -410,6 +410,12 @@
;
GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
;
+ % XXX STM - To Check
+ GoalExpr = atomic_goal(_GoalType, _Outer, _Inner, _Vars, MainGoal,
+ OrElseGoals),
+ add_dependency_arcs_in_goal(MainGoal, Caller, !DepGraph),
+ add_dependency_arcs_in_list(OrElseGoals, Caller, !DepGraph)
+ ;
GoalExpr = shorthand(ShorthandGoal),
ShorthandGoal = bi_implication(LHS, RHS),
add_dependency_arcs_in_list([LHS, RHS], Caller, !DepGraph)
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.208
diff -u -r1.208 det_analysis.m
--- compiler/det_analysis.m 7 Aug 2007 07:09:50 -0000 1.208
+++ compiler/det_analysis.m 9 Oct 2007 03:03:46 -0000
@@ -622,6 +622,15 @@
GoalFailingContexts, !Specs),
GoalExpr = GoalExpr0
;
+ GoalExpr0 = atomic_goal(GoalType, Inner, Outer, Vars, MainGoal0,
+ OrElseGoals0),
+ det_infer_atomic(MainGoal0, MainGoal, OrElseGoals0, OrElseGoals,
+ GoalInfo, InstMap0, SolnContext, RightFailingContexts,
+ MaybePromiseEqvSolutionSets, DetInfo, Detism, GoalFailingContexts,
+ !Specs),
+ GoalExpr = atomic_goal(GoalType, Inner, Outer, Vars, MainGoal,
+ OrElseGoals)
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "det_infer_goal_2: unexpected shorthand")
@@ -1293,6 +1302,147 @@
%-----------------------------------------------------------------------------%
+
+:- pred det_infer_atomic(hlds_goal::in, hlds_goal::out,
+ hlds_goals::in, hlds_goals::out, hlds_goal_info::in, instmap::in,
+ soln_context::in, list(failing_context)::in, maybe(pess_info)::in,
+ det_info::in, determinism::out, list(failing_context)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+det_infer_atomic(MainGoal0, MainGoal, OrElseGoals0, OrElseGoals,
+ GoalInfo, InstMap0, SolnContext, RightFailingContexts,
+ MaybePromiseEqvSolutionSets0, DetInfo, Detism, GoalFailingContexts,
+ !Specs) :-
+ (
+ OrElseGoals0 = [],
+ AnyOrElse = no
+ ;
+ OrElseGoals0 = [_ | _],
+ AnyOrElse = yes
+ ),
+ det_infer_atomic_main(AnyOrElse, MainGoal0, MainGoal, GoalInfo,
+ InstMap0, SolnContext, RightFailingContexts,
+ MaybePromiseEqvSolutionSets0, DetInfo, MainDetism,
+ MainGoalFailingContexts, !Specs),
+ (
+ OrElseGoals0 = [],
+ Detism = MainDetism,
+ GoalFailingContexts = MainGoalFailingContexts,
+ OrElseGoals = []
+ ;
+ OrElseGoals0 = [_ | _],
+ det_infer_orelse(OrElseGoals0, OrElseGoals, GoalInfo,
+ InstMap0, SolnContext, RightFailingContexts,
+ MaybePromiseEqvSolutionSets0, DetInfo, Detism,
+ GoalFailingContexts, !Specs)
+ ).
+
+:- pred det_infer_atomic_main(bool::in, hlds_goal::in, hlds_goal::out,
+ hlds_goal_info::in, instmap::in, soln_context::in,
+ list(failing_context)::in, maybe(pess_info)::in, det_info::in,
+ determinism::out, list(failing_context)::out, list(error_spec)::in,
+ list(error_spec)::out) is det.
+
+det_infer_atomic_main(_AtomicGoalHasOrElse, Goal0, Goal, GoalInfo, InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets0, DetInfo, Detism,
+ GoalFailingContexts, !Specs) :-
+ det_infer_goal(Goal0, Goal, InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets0, DetInfo,
+ Detism, GoalFailingContexts, !Specs),
+ (
+ ( Detism = detism_det
+ ; Detism = detism_cc_multi
+ ; Detism = detism_erroneous
+ )
+ ;
+ ( Detism = detism_semi
+ ; Detism = detism_multi
+ ; Detism = detism_non
+ ; Detism = detism_cc_non
+ ; Detism = detism_failure
+ ),
+ Context = goal_info_get_context(GoalInfo),
+ DetismStr = determinism_to_string(Detism),
+ Pieces = [words("Error: atomic goal has determinism"),
+ quote(DetismStr), suffix(","),
+ words("should be det or cc_multi.")],
+ Spec = error_spec(severity_error, phase_detism_check,
+ [simple_msg(Context, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+
+:- pred det_infer_orelse(list(hlds_goal)::in, list(hlds_goal)::out,
+ hlds_goal_info::in, instmap::in, soln_context::in,
+ list(failing_context)::in, maybe(pess_info)::in, det_info::in,
+ determinism::out, list(failing_context)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+det_infer_orelse(Goals0, Goals, GoalInfo, InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo,
+ Detism, GoalFailingContexts, !Specs) :-
+ det_infer_orelse_goals(Goals0, Goals, InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo,
+ can_fail, at_most_zero, Detism, [], GoalFailingContexts0, !Specs),
+ (
+ Goals = [],
+ Context = goal_info_get_context(GoalInfo),
+ FailingContext = failing_context(Context, fail_goal),
+ GoalFailingContexts = [FailingContext | GoalFailingContexts0]
+ ;
+ Goals = [_ | _],
+ % XXX Should we add to the failing contexts here?
+ GoalFailingContexts = GoalFailingContexts0
+ ).
+
+:- pred det_infer_orelse_goals(list(hlds_goal)::in, list(hlds_goal)::out,
+ instmap::in, soln_context::in, list(failing_context)::in,
+ maybe(pess_info)::in, det_info::in, can_fail::in, soln_count::in,
+ determinism::out, list(failing_context)::in, list(failing_context)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+det_infer_orelse_goals([], [], _InstMap0, _SolnContext, _RightFailingContexts,
+ _MaybePromiseEqvSolutionSets, _DetInfo, CanFail, MaxSolns, Detism,
+ !OrElseFailingContexts, !Specs) :-
+ determinism_components(Detism, CanFail, MaxSolns).
+det_infer_orelse_goals([Goal0 | Goals0], [Goal | Goals], InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo,
+ !.CanFail, !.MaxSolns, Detism, !OrElseFailingContexts, !Specs) :-
+ det_infer_goal(Goal0, Goal, InstMap0, SolnContext, RightFailingContexts,
+ MaybePromiseEqvSolutionSets, DetInfo, FirstDetism, GoalFailingContexts,
+ !Specs),
+ (
+ ( FirstDetism = detism_det
+ ; FirstDetism = detism_cc_multi
+ ; FirstDetism = detism_erroneous
+ )
+ ;
+ ( FirstDetism = detism_semi
+ ; FirstDetism = detism_multi
+ ; FirstDetism = detism_non
+ ; FirstDetism = detism_cc_non
+ ; FirstDetism = detism_failure
+ ),
+ Goal = hlds_goal(_, GoalInfo),
+ Context = goal_info_get_context(GoalInfo),
+ DetismStr = determinism_to_string(FirstDetism),
+ Pieces = [words("Error: atomic goal has determinism"),
+ quote(DetismStr), suffix(","),
+ words("should be det or cc_multi.")],
+ Spec = error_spec(severity_error, phase_detism_check,
+ [simple_msg(Context, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ),
+ determinism_components(FirstDetism, FirstCanFail, FirstMaxSolns),
+ det_disjunction_canfail(!.CanFail, FirstCanFail, !:CanFail),
+ det_disjunction_maxsoln(!.MaxSolns, FirstMaxSolns, !:MaxSolns),
+
+ det_infer_orelse_goals(Goals0, Goals, InstMap0, SolnContext,
+ RightFailingContexts, MaybePromiseEqvSolutionSets, DetInfo,
+ !.CanFail, !.MaxSolns, Detism, !OrElseFailingContexts, !Specs),
+ !:OrElseFailingContexts = GoalFailingContexts ++ !.OrElseFailingContexts.
+%-----------------------------------------------------------------------------%
+
:- pred det_infer_scope(scope_reason::in, hlds_goal::in, hlds_goal::out,
hlds_goal_info::in, instmap::in, soln_context::in,
list(failing_context)::in, maybe(pess_info)::in, det_info::in,
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.138
diff -u -r1.138 det_report.m
--- compiler/det_report.m 7 Aug 2007 07:09:51 -0000 1.138
+++ compiler/det_report.m 9 Oct 2007 03:03:55 -0000
@@ -633,6 +633,25 @@
Msgs = []
).
+det_diagnose_goal_2(atomic_goal(_, _, _, _, _, _), GoalInfo,
+ _, Actual, _, _, Msgs) :-
+ determinism_components(Actual, ActualCanFail, ActualSolns),
+ ( ActualCanFail = can_fail ->
+ Context = goal_info_get_context(GoalInfo),
+ Pieces = [words("Atomic goal can fail.")],
+ Msgs = [simple_msg(Context, [always(Pieces)])]
+ ; ActualSolns = at_most_zero ->
+ Context = goal_info_get_context(GoalInfo),
+ Pieces = [words("Atomic goal can fail.")],
+ Msgs = [simple_msg(Context, [always(Pieces)])]
+ ; ActualSolns = at_most_many ->
+ Context = goal_info_get_context(GoalInfo),
+ Pieces = [words("Atomic goal is nondet.")],
+ Msgs = [simple_msg(Context, [always(Pieces)])]
+ ;
+ Msgs = []
+ ).
+
det_diagnose_goal_2(scope(_, Goal), _, Desired, Actual, SwitchContext, DetInfo,
Msgs) :-
Goal = hlds_goal(_, GoalInfo),
Index: compiler/distance_granularity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/distance_granularity.m,v
retrieving revision 1.4
diff -u -r1.4 distance_granularity.m
--- compiler/distance_granularity.m 7 Aug 2007 07:09:51 -0000 1.4
+++ compiler/distance_granularity.m 9 Oct 2007 03:04:21 -0000
@@ -392,6 +392,9 @@
!:Goal = hlds_goal(GoalExpr, GoalInfo),
IsRecursiveCallInParallelConj = no
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "apply_dg_to_goal")
+ ;
GoalExpr0 = shorthand(_),
% Shorthand are not supposed to occur here.
unexpected(this_file, "apply_dg_to_goal")
@@ -924,6 +927,9 @@
GoalExpr = if_then_else(Vars, Cond, Then, Else),
!:Goal = hlds_goal(GoalExpr, GoalInfo)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ sorry(this_file, "update_original_predicate_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
% Shorthand are not supposed to occur here.
unexpected(this_file, "update_original_predicate_goal")
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.45
diff -u -r1.45 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 28 Sep 2007 03:17:11 -0000 1.45
+++ compiler/equiv_type_hlds.m 1 Oct 2007 02:44:09 -0000
@@ -15,8 +15,7 @@
% This is necessary to avoid problems with back-ends that don't support
% equivalence types properly (or at all).
%
-%-----------------------------------------------------------------------------%
-
+%-----------------------------------------------------------------------------%
:- module transform_hlds.equiv_type_hlds.
:- interface.
@@ -904,6 +903,23 @@
GoalExpr = GoalExpr0
)
).
+% XXX STM - To Check
+replace_in_goal_expr(EqvMap, GoalExpr0 @ atomic_goal(GoalType, Outer, Inner,
+ Vars, MainGoal0, OrElseAlternatives0), GoalExpr, Changed, !Info) :-
+ replace_in_goal(EqvMap, MainGoal0, MainGoal, Changed1, !Info),
+ replace_in_list(replace_in_goal(EqvMap), OrElseAlternatives0,
+ OrElseAlternatives, Changed2, !Info),
+ Changed = Changed1 `or` Changed2,
+ (
+ Changed = yes,
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseAlternatives)
+ ;
+ Changed = no,
+ GoalExpr = GoalExpr0
+ ).
+
+
replace_in_goal_expr(_, shorthand(_), _, _, !Info) :-
unexpected(this_file, "replace_in_goal_expr: shorthand").
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.28
diff -u -r1.28 erl_code_gen.m
--- compiler/erl_code_gen.m 4 Oct 2007 05:23:01 -0000 1.28
+++ compiler/erl_code_gen.m 9 Oct 2007 03:04:57 -0000
@@ -620,6 +620,10 @@
erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap,
Context, MaybeSuccessExpr, Statement, !Info).
+erl_gen_goal_expr(atomic_goal(_, _, _, _, _, _), _CodeModel, _Detism,
+ _InstMap, _Context, _MaybeSucessExpr, _Statement, !Info) :-
+ unexpected(this_file, "erl_gen_goal_expr: atomic_goal").
+
erl_gen_goal_expr(scope(ScopeReason, Goal), CodeModel, Detism, InstMap,
Context, MaybeSuccessExpr, Statement, !Info) :-
(
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.40
diff -u -r1.40 exception_analysis.m
--- compiler/exception_analysis.m 20 Aug 2007 03:35:53 -0000 1.40
+++ compiler/exception_analysis.m 9 Oct 2007 03:05:04 -0000
@@ -513,6 +513,10 @@
;
MayCallMercury = proc_will_not_call_mercury
).
+check_goal_for_exceptions_2(_, _, atomic_goal(_, _, _, _, _, _),
+ _, _, _, _, _, _, _) :-
+ unexpected(this_file,
+ "atomic goal encountered during exception analysis.").
check_goal_for_exceptions_2(_, _, shorthand(_), _, _, _, _, _, _, _) :-
unexpected(this_file,
"shorthand goal encountered during exception analysis.").
Index: compiler/follow_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/follow_code.m,v
retrieving revision 1.91
diff -u -r1.91 follow_code.m
--- compiler/follow_code.m 7 Aug 2007 10:03:47 -0000 1.91
+++ compiler/follow_code.m 9 Oct 2007 03:05:14 -0000
@@ -155,6 +155,10 @@
),
Goal = Goal0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "move_follow_code_in_goal: unexpected shorthand")
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file,
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.87
diff -u -r1.87 follow_vars.m
--- compiler/follow_vars.m 6 Jan 2007 09:23:31 -0000 1.87
+++ compiler/follow_vars.m 9 Oct 2007 03:05:24 -0000
@@ -215,6 +215,12 @@
find_follow_vars_in_goal_expr(Goal @ call_foreign_proc(_, _, _, _, _, _, _),
Goal, GoalInfo, GoalInfo, _, _, !FollowVarsMap, !NextNonReserved).
+find_follow_vars_in_goal_expr(atomic_goal(_, _, _, _, _, _), _, _, _, _,
+ _, _, _, _, _) :-
+ % these should have been expanded out by now
+ unexpected(this_file,
+ "find_follow_vars_in_goal_2: unexpected atomic goal").
+
find_follow_vars_in_goal_expr(shorthand(_), _, _, _, _, _, _, _, _, _) :-
% these should have been expanded out by now
unexpected(this_file, "find_follow_vars_in_goal_2: unexpected shorthand").
Index: compiler/format_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/format_call.m,v
retrieving revision 1.11
diff -u -r1.11 format_call.m
--- compiler/format_call.m 7 Aug 2007 07:09:53 -0000 1.11
+++ compiler/format_call.m 9 Oct 2007 03:05:42 -0000
@@ -469,6 +469,11 @@
GoalExpr = unify(_, _, _, Unification, _),
traverse_unify(Unification, CurId, !ConjMaps, !PredMap, !RelevantVars)
;
+ GoalExpr = atomic_goal(_, _, _, _, MainGoal, OrElseAlternatives),
+ traverse_disj([MainGoal | OrElseAlternatives], CurId,
+ !FormatCallSites, !Counter, !ConjMaps, !PredMap, !RelevantVars,
+ ModuleInfo)
+ ;
GoalExpr = shorthand(_),
% These should have been expanded by now.
unexpected(this_file, "traverse_conj: shorthand")
Index: compiler/goal_form.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.39
diff -u -r1.39 goal_form.m
--- compiler/goal_form.m 7 Aug 2007 07:09:53 -0000 1.39
+++ compiler/goal_form.m 9 Oct 2007 03:05:59 -0000
@@ -243,6 +243,15 @@
OuterGoal = scope(_, InnerGoal)
),
goal_can_throw(InnerGoal, Result, !ModuleInfo, !IO).
+
+% Atomic goals currently throw an exception to signal a rollback so
+% it is pretty safe to say that any goal inside an atomic goal can throw
+% an exception.
+goal_can_throw_2(Goal, _GoalInfo, Result, !ModuleInfo, !IO) :-
+ Goal = atomic_goal(_GoalType, _Outer, _Inner, _Vars, _MainGoal,
+ _OrElseAlternatives),
+ Result = can_throw.
+
goal_can_throw_2(Goal, _, Result, !ModuleInfo, !IO) :-
Goal = call_foreign_proc(Attributes, _, _, _, _, _, _),
ExceptionStatus = get_may_throw_exception(Attributes),
@@ -398,6 +407,12 @@
;
CanLoop = yes
).
+goal_expr_can_loop(MaybeModuleInfo, Goal) = CanLoop :-
+ Goal = atomic_goal(_, _, _, _, MainGoal, OrElseAlternatives),
+ MainGoal = hlds_goal(MainGoalExpr, _),
+ MainGoalCanLoop = goal_expr_can_loop(MaybeModuleInfo, MainGoalExpr),
+ OrElseCanLoop = goal_list_can_loop(MaybeModuleInfo, OrElseAlternatives),
+ CanLoop = MainGoalCanLoop `or` OrElseCanLoop.
goal_expr_can_loop(_MaybeModuleInfo, Goal) = yes :-
% We have no idea whether the called goal can throw exceptions,
% at least without closure analysis.
@@ -524,6 +539,8 @@
% predicate.
CanThrow = yes
).
+goal_expr_can_throw(_, atomic_goal(_, _, _, _, _, _)) = yes.
+
goal_expr_can_throw(_, shorthand(_)) = _ :-
unexpected(this_file, "goal_expr_can_throw: shorthand").
@@ -570,6 +587,7 @@
goal_is_flat_expr(if_then_else(_, _, _, _)) = no.
goal_is_flat_expr(negation(Goal)) = goal_is_flat(Goal).
goal_is_flat_expr(scope(_, Goal)) = goal_is_flat(Goal).
+goal_is_flat_expr(atomic_goal(_, _, _, _, _, _)) = no.
goal_is_flat_expr(shorthand(_)) = no.
:- func goal_is_flat_list(list(hlds_goal)) = bool.
@@ -643,6 +661,8 @@
;
goal_may_allocate_heap(E, May)
).
+goal_may_allocate_heap_2(atomic_goal(_, _, _, _, _, _), May) :-
+ May = yes.
goal_may_allocate_heap_2(shorthand(ShorthandGoal), May) :-
goal_may_allocate_heap_2_shorthand(ShorthandGoal, May).
@@ -790,6 +810,13 @@
CTMax = CMax + TMax,
int.min(CTMin, EMin, Min),
int.max(CTMax, EMax, Max).
+count_recursive_calls_2(atomic_goal(_, _, _, _, MainGoal, OrElseAlternatives),
+ PredId, ProcId, Min, Max) :-
+ count_recursive_calls(MainGoal, PredId, ProcId, MMin, MMax),
+ count_recursive_calls_disj(OrElseAlternatives, PredId, ProcId,
+ OMin, OMax),
+ int.min(MMin, OMin, Min),
+ int.max(MMax, OMax, Max).
count_recursive_calls_2(shorthand(_), _, _, _, _) :-
% these should have been expanded out by now
unexpected(this_file, "count_recursive_calls_2: unexpected shorthand").
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.44
diff -u -r1.44 goal_path.m
--- compiler/goal_path.m 7 Aug 2007 07:09:53 -0000 1.44
+++ compiler/goal_path.m 9 Oct 2007 03:06:06 -0000
@@ -200,6 +200,14 @@
Goal0 = call_foreign_proc(_, _, _, _, _, _, _),
Goal = Goal0
;
+ Goal0 = atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal0, OrElseGoals0),
+ fill_goal_slots([step_atomic_main | Path0], SlotInfo,
+ MainGoal0, MainGoal),
+ fill_orelse_slots(Path0, 0, SlotInfo, OrElseGoals0, OrElseGoals),
+ Goal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals)
+ ;
Goal0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "fill_expr_slots: unexpected shorthand")
@@ -234,6 +242,15 @@
Goal0, Goal),
fill_switch_slots(Path0, N1, MaybeNumFunctors, SlotInfo, Cases0, Cases).
+:- pred fill_orelse_slots(goal_path::in, int::in, slot_info::in,
+ list(hlds_goal)::in, list(hlds_goal)::out) is det.
+
+fill_orelse_slots(_, _, _, [], []).
+fill_orelse_slots(Path0, N0, SlotInfo, [Goal0 | Goals0], [Goal | Goals]) :-
+ N1 = N0 + 1,
+ fill_goal_slots([step_atomic_orelse(N1) | Path0], SlotInfo, Goal0, Goal),
+ fill_orelse_slots(Path0, N1, SlotInfo, Goals0, Goals).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.151
diff -u -r1.151 goal_util.m
--- compiler/goal_util.m 7 Aug 2007 07:09:53 -0000 1.151
+++ compiler/goal_util.m 9 Oct 2007 03:06:20 -0000
@@ -526,6 +526,32 @@
ExtraVars = list.map(foreign_arg_var, ExtraArgs),
svset.insert_list(list.append(ArgVars, ExtraVars), !Set).
+goal_vars_2(atomic_goal(_, Outer, Inner, Vars, MainGoal, OrElseGoals), !Set) :-
+ (
+ Outer = atomic_state_var(_),
+ unexpected(this_file, "atomic_goal: seen atomic_state_var")
+ ;
+ Outer = atomic_var_pair(OVarDI, OVarUO),
+ svset.insert(OVarDI, !Set),
+ svset.insert(OVarUO, !Set)
+ ),
+ (
+ Inner = atomic_state_var(_),
+ unexpected(this_file, "atomic_goal: seen atomic_state_var")
+ ;
+ Inner = atomic_var_pair(IVarDI, IVarUO),
+ svset.insert(IVarDI, !Set),
+ svset.insert(IVarUO, !Set)
+ ),
+ (
+ Vars = no
+ ;
+ Vars = yes(VarList),
+ svset.insert_list(VarList, !Set)
+ ),
+ goal_vars_2(MainGoal ^ hlds_goal_expr, !Set),
+ goals_goal_vars(OrElseGoals, !Set).
+
goal_vars_2(shorthand(ShorthandGoal), !Set) :-
goal_vars_2_shorthand(ShorthandGoal, !Set).
@@ -626,6 +652,14 @@
GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _),
GoalExpr = GoalExpr0
;
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ attach_features_to_all_goals(Features, MainGoal0, MainGoal),
+ list.map(attach_features_to_all_goals(Features), OrElseGoals0,
+ OrElseGoals),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals)
+ ;
GoalExpr0 = shorthand(_),
GoalExpr = GoalExpr0
).
@@ -712,6 +746,9 @@
GoalExpr = switch(_, _, Cases),
IsLeaf = proc_body_is_leaf_cases(Cases)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ IsLeaf = is_not_leaf
+ ;
GoalExpr = if_then_else(_, Cond, Then, Else),
(
proc_body_is_leaf(Cond) = is_leaf,
@@ -835,6 +872,10 @@
goal_expr_size(generic_call(_, _, _, _), 1).
goal_expr_size(unify(_, _, _, _, _), 1).
goal_expr_size(call_foreign_proc(_, _, _, _, _, _, _), 1).
+goal_expr_size(atomic_goal(_, _, _, _, MainGoal, OrElseGoals), Size) :-
+ goal_size(MainGoal, Size1),
+ goals_size(OrElseGoals, Size2),
+ Size = Size1 + Size2 + 1.
goal_expr_size(shorthand(ShorthandGoal), Size) :-
goal_expr_size_shorthand(ShorthandGoal, Size).
@@ -1010,6 +1051,10 @@
GoalExpr = scope(_, Goal),
goal_calls_proc_in_list_2(Goal, PredProcIds, !CalledSet)
;
+ GoalExpr = atomic_goal(_, _, _, _, MainGoal, OrElseGoals),
+ goal_calls_proc_in_list_2(MainGoal, PredProcIds, !CalledSet),
+ goal_list_calls_proc_in_list_2(OrElseGoals, PredProcIds, !CalledSet)
+ ;
GoalExpr = shorthand(_),
unexpected(this_file, "goal__calls_proc_in_list_2: shorthand")
).
@@ -1584,6 +1629,14 @@
GoalExpr = negation(SubGoal),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ MainGoal = maybe_strip_equality_pretest(MainGoal0),
+ OrElseGoals = list.map(maybe_strip_equality_pretest, OrElseGoals0),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals),
+ Goal = hlds_goal(GoalExpr, GoalInfo0)
+ ;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
( goal_info_has_feature(GoalInfo0, feature_pretest_equality) ->
Goal = Else0
Index: compiler/granularity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/granularity.m,v
retrieving revision 1.9
diff -u -r1.9 granularity.m
--- compiler/granularity.m 7 Aug 2007 07:09:53 -0000 1.9
+++ compiler/granularity.m 1 Oct 2007 02:44:09 -0000
@@ -203,6 +203,9 @@
),
GoalExpr = GoalExpr0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ sorry(this_file, "runtime_granularity_test_in_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "runtime_granularity_test_in_goal: shorthand")
),
Index: compiler/hhf.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hhf.m,v
retrieving revision 1.32
diff -u -r1.32 hhf.m
--- compiler/hhf.m 7 Aug 2007 07:09:54 -0000 1.32
+++ compiler/hhf.m 1 Oct 2007 02:44:09 -0000
@@ -281,6 +281,9 @@
Else = hlds_goal(ElseExpr, ElseInfo),
GoalExpr = if_then_else(Vs, Cond, Then, Else)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ sorry(this_file, "hhf_goal_expr: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "hhf_goal_expr: found shorthand")
).
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.169
diff -u -r1.169 higher_order.m
--- compiler/higher_order.m 20 Aug 2007 03:35:54 -0000 1.169
+++ compiler/higher_order.m 1 Oct 2007 02:44:09 -0000
@@ -619,6 +619,9 @@
true
).
+traverse_goal_2(hlds_goal(atomic_goal(_, _, _, _, _, _), _), _, !Info) :-
+ unexpected(this_file, "traverse_goal_2: atomic_goal").
+
traverse_goal_2(hlds_goal(shorthand(_), _), _, !Info) :-
% These should have been expanded out by now.
unexpected(this_file, "traverse_goal_2: unexpected shorthand").
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.182
diff -u -r1.182 hlds_goal.m
--- compiler/hlds_goal.m 28 Sep 2007 03:17:11 -0000 1.182
+++ compiler/hlds_goal.m 1 Oct 2007 02:44:09 -0000
@@ -199,6 +199,50 @@
scope_goal :: hlds_goal
)
+ ; atomic_goal(
+ % An atomic goal that will be executed atomically against
+ % all running threads using the stm system.
+
+ atomic_goal_type :: atomic_goal_type,
+ % The type of atomic goal. Either
+ % a toplevel atomic goal or a nested
+ % atomic goal. This isn't known
+ % until after typechecking.
+
+ atomic_outer :: atomic_component_state,
+ % The outer atomic variables. Either
+ % represented as a pair of prog_vars
+ % (shen specified in the program as
+ % `outer(Var1, Var2)`) or a single
+ % state prog_var (when specified in the
+ % program as `outer(!Var)`.
+
+ atomic_inner :: atomic_component_state,
+ % The inner atomic variables. Either
+ % represented as a pair of prog_vars
+ % (shen specified in the program as
+ % `inner(Var1, Var2)`) or a single
+ % state prog_var (when specified in the
+ % program as `inner(!Var)`.
+
+ atomic_output_vars :: maybe(list(prog_var)),
+ % List of specified output variables
+ % (that exist within the `var(...)`
+ % functor). These variables will be
+ % free when the atomic goal is started and
+ % grounded when the atomic goal is
+ % complete.
+
+ atomic_main_goal :: hlds_goal,
+ % The main atomic transaction goal. If
+ % any or_else goals also exist, this goal
+ % is the first or_else alternative.
+
+ orelse_alternatives :: hlds_goals
+ % Any other or_else alternative goals.
+
+ )
+
; if_then_else(
% An if-then-else,
% `if some <Vars> <Condition> then <Then> else <Else>'.
@@ -220,6 +264,7 @@
% All shorthand goals are eliminated during or shortly after
% the construction of the HLDS, so most passes of the compiler
% will just call error/1 if they occur.
+
:- type conj_type
---> plain_conj
@@ -229,6 +274,12 @@
---> before_semantic_analysis
; after_semantic_analysis.
+:- type atomic_goal_type
+ ---> unknown_atomic_goal_type
+ ; top_level_atomic_goal
+ ; nested_atomic_goal.
+
+
% Instances of these `shorthand' goals are implemented by a
% hlds --> hlds transformation that replaces them with
% equivalent non-shorthand goals.
@@ -337,6 +388,7 @@
% HLDS, since they are fully processed when the corresponding goal
% in the parse tree is converted to HLDS.
+
:- type promise_solutions_kind
---> equivalent_solutions
; equivalent_solution_sets
@@ -2154,11 +2206,60 @@
Expr = call_foreign_proc(Attrs, PredId, ProcId, Args, Extra,
MTRC, Impl)
;
+ Expr0 = atomic_goal(_, _, _, _, _, _),
+ rename_vars_in_atomic_goal(Must, Subn, Expr0, Expr)
+ ;
Expr0 = shorthand(ShorthandGoal0),
rename_vars_in_shorthand(Must, Subn, ShorthandGoal0, ShorthandGoal),
Expr = shorthand(ShorthandGoal)
).
+:- pred rename_vars_in_atomic_goal(must_rename::in, prog_var_renaming::in,
+ hlds_goal_expr::in, hlds_goal_expr::out) is det.
+
+rename_vars_in_atomic_goal(Must, Subn, Expr0, Expr) :-
+ (
+ Expr0 = atomic_goal(GoalType0, Outer0, Inner0, Vars0,
+ MainGoal0, OrElseGoals0)
+ ->
+ GoalType = GoalType0,
+ (
+ Outer0 = atomic_state_var(OuterStateVar0),
+ rename_var(Must, Subn, OuterStateVar0, OuterStateVar),
+ Outer = atomic_state_var(OuterStateVar)
+ ;
+ Outer0 = atomic_var_pair(OuterDI0, OuterUO0),
+ rename_var(Must, Subn, OuterDI0, OuterDI),
+ rename_var(Must, Subn, OuterUO0, OuterUO),
+ Outer = atomic_var_pair(OuterDI, OuterUO)
+ ),
+ (
+ Inner0 = atomic_state_var(InnerStateVar0),
+ rename_var(Must, Subn, InnerStateVar0, InnerStateVar),
+ Inner = atomic_state_var(InnerStateVar)
+ ;
+ Inner0 = atomic_var_pair(InnerDI0, InnerUO0),
+ rename_var(Must, Subn, InnerDI0, InnerDI),
+ rename_var(Must, Subn, InnerUO0, InnerUO),
+ Inner = atomic_var_pair(InnerDI, InnerUO)
+ ),
+ (
+ Vars0 = no,
+ Vars = Vars0
+ ;
+ Vars0 = yes(VarList0),
+ rename_var_list(Must, Subn, VarList0, VarList),
+ Vars = yes(VarList)
+ ),
+ rename_vars_in_goal(Must, Subn, MainGoal0, MainGoal),
+ rename_vars_in_goals(Must, Subn, OrElseGoals0, OrElseGoals),
+ Expr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals)
+ ;
+ unexpected(this_file, "rename_vars_in_atomic_goal called without" ++
+ "atomic goal")
+ ).
+
:- pred rename_vars_in_shorthand(must_rename::in, prog_var_renaming::in,
shorthand_goal_expr::in, shorthand_goal_expr::out) is det.
@@ -2552,6 +2653,9 @@
HasForeign = no
)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ HasForeign = yes
+ ;
GoalExpr = call_foreign_proc(_, _, _, _, _, _, _),
HasForeign = yes
;
@@ -2601,6 +2705,11 @@
goal_is_atomic(scope(_, _)) = no.
goal_is_atomic(shorthand(_)) = no.
+ % The atomic_goal functor in this clause does not refer to the actual
+ % atomicity of the hlds_goal but to the Software Transactional Memory
+ % construct "atomic".
+goal_is_atomic(atomic_goal(_, _, _, _, _, _)) = no.
+
%-----------------------------------------------------------------------------%
true_goal = hlds_goal(true_goal_expr, GoalInfo) :-
@@ -2697,6 +2806,12 @@
Goal = unify(_, _, _, _, _).
set_goal_contexts_2(_, Goal, Goal) :-
Goal = call_foreign_proc(_, _, _, _, _, _, _).
+set_goal_contexts_2(Context,
+ atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0, OrElseGoals0),
+ atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals)) :-
+ set_goal_contexts(Context, MainGoal0, MainGoal),
+ list.map(set_goal_contexts(Context), OrElseGoals0, OrElseGoals).
+
set_goal_contexts_2(Context, shorthand(ShorthandGoal0),
shorthand(ShorthandGoal)) :-
set_goal_contexts_2_shorthand(Context, ShorthandGoal0, ShorthandGoal).
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.155
diff -u -r1.155 hlds_module.m
--- compiler/hlds_module.m 7 Sep 2007 15:08:17 -0000 1.155
+++ compiler/hlds_module.m 1 Oct 2007 02:44:10 -0000
@@ -635,6 +635,9 @@
:- pred module_info_next_lambda_count(prog_context::in, int::out,
module_info::in, module_info::out) is det.
+:- pred module_info_next_atomic_count(prog_context::in, int::out,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_next_model_non_pragma_count(int::out,
module_info::in, module_info::out) is det.
@@ -673,6 +676,12 @@
:- pred module_info_set_lambdas_per_context(map(prog_context, counter)::in,
module_info::in, module_info::out) is det.
+:- pred module_info_get_atomics_per_context(module_info::in,
+ map(prog_context, counter)::out) is det.
+
+:- pred module_info_set_atomics_per_context(map(prog_context, counter)::in,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_get_model_non_pragma_counter(module_info::in, counter::out)
is det.
@@ -759,6 +768,12 @@
% expressions that appear on the same line of the same file.
lambdas_per_context :: map(prog_context, counter),
+ % How many STM atomic expressions there are at different
+ % contexts in the module. This is used to uniquely identify
+ % STM atomic expressions that appear on the same line of
+ % the same file.
+ atomics_per_context :: map(prog_context, counter),
+
% Used to ensure uniqueness of the structure types defined
% so far for model_non foreign_procs.
model_non_pragma_counter :: counter,
@@ -839,6 +854,7 @@
map.init(TablingStructMap),
map.init(MM_TablingInfo),
map.init(LambdasPerContext),
+ map.init(AtomicsPerContext),
counter.init(1, ModelNonPragmaCounter),
% The builtin modules are automatically imported.
@@ -872,7 +888,8 @@
MaybeDependencyInfo, NumErrors, PragmaExportedProcs,
MustBeStratifiedPreds, StratPreds, UnusedArgInfo,
ExceptionInfo, TrailingInfo, TablingStructMap, MM_TablingInfo,
- LambdasPerContext, ModelNonPragmaCounter, ImportedModules,
+ LambdasPerContext, AtomicsPerContext, ModelNonPragmaCounter,
+ ImportedModules,
IndirectlyImportedModules, TypeSpecInfo, NoTagTypes,
MaybeComplexityMap, ComplexityProcInfos,
AnalysisInfo, UserInitPredCNames, UserFinalPredCNames,
@@ -968,6 +985,7 @@
module_info_get_table_struct_map(MI, MI ^ sub_info ^ table_struct_map).
module_info_get_mm_tabling_info(MI, MI ^ sub_info ^ mm_tabling_info).
module_info_get_lambdas_per_context(MI, MI ^ sub_info ^ lambdas_per_context).
+module_info_get_atomics_per_context(MI, MI ^ sub_info ^ atomics_per_context).
module_info_get_model_non_pragma_counter(MI,
MI ^ sub_info ^ model_non_pragma_counter).
module_info_get_imported_module_specifiers(MI,
@@ -1100,6 +1118,8 @@
MI ^ sub_info ^ mm_tabling_info := NewVal).
module_info_set_lambdas_per_context(NewVal, MI,
MI ^ sub_info ^ lambdas_per_context := NewVal).
+module_info_set_atomics_per_context(NewVal, MI,
+ MI ^ sub_info ^ atomics_per_context := NewVal).
module_info_set_model_non_pragma_counter(NewVal, MI,
MI ^ sub_info ^ model_non_pragma_counter := NewVal).
module_add_imported_module_specifiers(IStat, ModuleSpecifiers, !MI) :-
@@ -1268,6 +1288,21 @@
),
module_info_set_lambdas_per_context(ContextCounter, !MI).
+module_info_next_atomic_count(Context, Count, !MI) :-
+ module_info_get_atomics_per_context(!.MI, ContextCounter0),
+ (
+ map.insert(ContextCounter0, Context, counter.init(2),
+ FoundContextCounter)
+ ->
+ Count = 1,
+ ContextCounter = FoundContextCounter
+ ;
+ map.lookup(ContextCounter0, Context, Counter0),
+ counter.allocate(Count, Counter0, Counter),
+ map.det_update(ContextCounter0, Context, Counter, ContextCounter)
+ ),
+ module_info_set_atomics_per_context(ContextCounter, !MI).
+
module_info_next_model_non_pragma_count(Count, !MI) :-
module_info_get_model_non_pragma_counter(!.MI, Counter0),
counter.allocate(Count, Counter0, Counter),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.436
diff -u -r1.436 hlds_out.m
--- compiler/hlds_out.m 28 Sep 2007 06:47:12 -0000 1.436
+++ compiler/hlds_out.m 9 Oct 2007 03:06:30 -0000
@@ -2069,11 +2069,67 @@
io.write_string(")", !IO),
io.write_string(Follow, !IO).
+write_goal_2(atomic_goal(_GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals),
+ ModuleInfo, VarSet, AppendVarNums, Indent, Follow, TypeQual, !IO) :-
+ write_indent(Indent, !IO),
+ io.write_string("atomic [", !IO),
+ write_atomic_comp_state("outer", Outer, VarSet, AppendVarNums, !IO),
+ io.write_string(" ", !IO),
+ write_atomic_comp_state("inner", Inner, VarSet, AppendVarNums, !IO),
+ io.write_string(" ", !IO),
+ (
+ Vars = no
+ ;
+ Vars = yes(OutVars),
+ io.write_string("vars([", !IO),
+ mercury_output_vars(VarSet, AppendVarNums, OutVars, !IO),
+ io.write_string("])", !IO)
+ ),
+ io.write_string("] (\n",!IO),
+
+ write_goal_a(MainGoal, ModuleInfo, VarSet, AppendVarNums,
+ Indent+1, "\n", TypeQual, !IO),
+ write_goal_list(OrElseGoals, ModuleInfo, VarSet, AppendVarNums,
+ Indent, "or_else\n", TypeQual, !IO),
+ write_indent(Indent, !IO),
+ io.write_string(")", !IO),
+ io.write_string(Follow, !IO).
+
write_goal_2(shorthand(ShortHandGoal), ModuleInfo, VarSet, AppendVarNums,
Indent, Follow, TypeQual, !IO) :-
write_goal_2_shorthand(ShortHandGoal, ModuleInfo, VarSet, AppendVarNums,
Indent, Follow, TypeQual, !IO).
+:- pred write_atomic_comp_state(string::in, atomic_component_state::in,
+ prog_varset::in, bool::in, io::di, io::uo) is det.
+
+write_atomic_comp_state(CompName, CompState, VarSet, AppendVarNums, !IO) :-
+ io.write_string(CompName, !IO),
+ io.write_string("(", !IO),
+ (
+ CompState = atomic_state_var(SVar),
+ mercury_output_var(VarSet, AppendVarNums, SVar, !IO)
+ ;
+ CompState = atomic_var_pair(Var1, Var2),
+ mercury_output_var(VarSet, AppendVarNums, Var1, !IO),
+ io.write_string(", ", !IO),
+ mercury_output_var(VarSet, AppendVarNums, Var2, !IO)
+ ),
+ io.write_string(")", !IO).
+
+:- pred write_or_else_list(hlds_goals::in, module_info::in, prog_varset::in,
+ bool::in, int::in, string::in, maybe_vartypes::in, io::di, io::uo) is det.
+
+write_or_else_list([], _, _, _, _, _, _, !IO).
+write_or_else_list([Goal | Goals], ModuleInfo, VarSet, AppendVarNums, Indent,
+ Follow, TypeQual, !IO) :-
+ write_indent(Indent, !IO),
+ io.write_string("or_else\n", !IO),
+ write_goal_a(Goal, ModuleInfo, VarSet, AppendVarNums, Indent+1, Follow,
+ TypeQual, !IO),
+ write_or_else_list(Goals, ModuleInfo, VarSet, AppendVarNums, Indent+1,
+ Follow, TypeQual, !IO).
+
:- pred write_goal_2_shorthand(shorthand_goal_expr::in, module_info::in,
prog_varset::in, bool::in, int::in, string::in, maybe_vartypes::in,
io::di, io::uo) is det.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.233
diff -u -r1.233 hlds_pred.m
--- compiler/hlds_pred.m 11 Sep 2007 01:41:10 -0000 1.233
+++ compiler/hlds_pred.m 9 Oct 2007 03:06:43 -0000
@@ -470,6 +470,7 @@
% pointer.
)
; transform_table_generator
+ ; transform_stm_expansion
; transform_dnf(
int % This predicate was originally part of a predicate
% transformed into disjunctive normal form; this integer
Index: compiler/implicit_parallelism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/implicit_parallelism.m,v
retrieving revision 1.4
diff -u -r1.4 implicit_parallelism.m
--- compiler/implicit_parallelism.m 7 Aug 2007 07:09:56 -0000 1.4
+++ compiler/implicit_parallelism.m 1 Oct 2007 02:44:10 -0000
@@ -301,6 +301,10 @@
update_conj_and_index(!MaybeConj, GoalProcessed, !IndexInConj),
!:Goal = GoalProcessed
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "process_goal_for_implicit_parallelism: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
increment_index_if_in_conj(!.MaybeConj, !IndexInConj)
).
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.157
diff -u -r1.157 inlining.m
--- compiler/inlining.m 8 Aug 2007 05:08:39 -0000 1.157
+++ compiler/inlining.m 1 Oct 2007 02:44:10 -0000
@@ -598,6 +598,9 @@
GoalExpr = GoalExpr0,
GoalInfo = GoalInfo0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "inlining_in_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "inlining_in_goal: unexpected shorthand")
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.224
diff -u -r1.224 intermod.m
--- compiler/intermod.m 25 Sep 2007 04:56:39 -0000 1.224
+++ compiler/intermod.m 1 Oct 2007 02:44:10 -0000
@@ -519,6 +519,14 @@
% non-exported types, so we just write out the clauses.
intermod_traverse_goal_expr(Goal @ call_foreign_proc(_, _, _, _, _, _, _),
Goal, yes, !Info).
+intermod_traverse_goal_expr(
+ atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0, OrElseGoals0),
+ atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals),
+ DoWrite, !Info) :-
+ intermod_traverse_goal(MainGoal0, MainGoal, DoWrite1, !Info),
+ intermod_traverse_list_of_goals(OrElseGoals0, OrElseGoals, DoWrite2,
+ !Info),
+ bool.and(DoWrite1, DoWrite2, DoWrite).
intermod_traverse_goal_expr(shorthand(_), _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "traverse_goal: unexpected shorthand").
Index: compiler/interval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/interval.m,v
retrieving revision 1.33
diff -u -r1.33 interval.m
--- compiler/interval.m 28 Sep 2007 03:17:12 -0000 1.33
+++ compiler/interval.m 1 Oct 2007 02:44:10 -0000
@@ -395,6 +395,9 @@
"build_interval_info_in_goal: complicated_unify")
)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "atomic_goal in build_interval_info_in_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(this_file, "shorthand in build_interval_info_in_goal")
).
@@ -928,23 +931,16 @@
rename_var_list(need_not_rename, !.VarRename, Vars0, Vars),
Reason = exist_quant(Vars)
;
- Reason0 = promise_purity(_, _),
- Reason = Reason0
- ;
- Reason0 = promise_solutions(_, _),
- Reason = Reason0
- ;
- Reason0 = commit(_),
- Reason = Reason0
- ;
- Reason0 = barrier(_),
- Reason = Reason0
- ;
Reason0 = from_ground_term(Var0),
rename_var(need_not_rename, !.VarRename, Var0, Var),
Reason = from_ground_term(Var)
;
- Reason0 = trace_goal(_, _, _, _, _),
+ ( Reason0 = promise_purity(_, _)
+ ; Reason0 = promise_solutions(_, _)
+ ; Reason0 = commit(_)
+ ; Reason0 = barrier(_)
+ ; Reason0 = trace_goal(_, _, _, _, _)
+ ),
Reason = Reason0
),
record_decisions_in_goal(SubGoal0, SubGoal, !VarInfo, !VarRename,
@@ -978,6 +974,9 @@
GoalExpr0 = unify(_, _, _, _, _),
rename_some_vars_in_goal(!.VarRename, Goal0, Goal)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "record_decisions_in_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "shorthand in record_decisions_in_goal")
).
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.131
diff -u -r1.131 lambda.m
--- compiler/lambda.m 4 Sep 2007 03:12:20 -0000 1.131
+++ compiler/lambda.m 1 Oct 2007 02:44:10 -0000
@@ -254,6 +254,13 @@
),
GoalExpr = GoalExpr0
;
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ lambda_process_goal(MainGoal0, MainGoal, !Info),
+ lambda_process_goal_list(OrElseGoals0, OrElseGoals, !Info),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal, OrElseGoals)
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "lambda_process_goal_2: unexpected shorthand")
Index: compiler/layout_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/layout_out.m,v
retrieving revision 1.93
diff -u -r1.93 layout_out.m
--- compiler/layout_out.m 12 Sep 2007 06:21:07 -0000 1.93
+++ compiler/layout_out.m 1 Oct 2007 02:44:10 -0000
@@ -1456,6 +1456,7 @@
"retptr_" ++ int_to_string(proc_id_to_int(ProcId)) ++ "_args"
++ ints_to_string(ArgPos).
pred_transform_name(transform_table_generator) = "table_gen".
+pred_transform_name(transform_stm_expansion) = "stm_expansion".
pred_transform_name(transform_dnf(N)) = "dnf_" ++ int_to_string(N).
:- func ints_to_string(list(int)) = string.
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.47
diff -u -r1.47 lco.m
--- compiler/lco.m 28 Sep 2007 03:17:12 -0000 1.47
+++ compiler/lco.m 1 Oct 2007 02:44:10 -0000
@@ -403,6 +403,9 @@
),
GoalExpr = GoalExpr0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "lco_in_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "lco_in_goal: shorthand")
).
@@ -930,6 +933,9 @@
transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
GoalInfo0, GoalExpr0, GoalExpr, Changed)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "transform_variant_goal: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "transform_variant_goal: shorthand")
),
Index: compiler/live_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/live_vars.m,v
retrieving revision 1.131
diff -u -r1.131 live_vars.m
--- compiler/live_vars.m 7 Aug 2007 07:09:57 -0000 1.131
+++ compiler/live_vars.m 1 Oct 2007 02:44:10 -0000
@@ -411,6 +411,10 @@
!ParStackVars)
).
+build_live_sets_in_goal_2(atomic_goal(_,_,_,_,_,_), _,_,_,_,_,_,_,_,_,_,
+ _,_,_) :-
+ unexpected(this_file, "build_live_sets_in_goal_2: unexpected atomic_goal").
+
build_live_sets_in_goal_2(shorthand(_), _,_,_,_,_,_,_,_,_,_,_,_,_) :-
% these should have been expanded out by now
unexpected(this_file, "build_live_sets_in_goal_2: unexpected shorthand").
Index: compiler/liveness.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/liveness.m,v
retrieving revision 1.156
diff -u -r1.156 liveness.m
--- compiler/liveness.m 7 Aug 2007 07:09:57 -0000 1.156
+++ compiler/liveness.m 1 Oct 2007 02:44:10 -0000
@@ -484,6 +484,9 @@
_, _, _, _, _) :-
unexpected(this_file, "foreign_proc in detect_liveness_in_goal_2").
+detect_liveness_in_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _, _) :-
+ unexpected(this_file, "detect_liveness_in_goal_2: atomic_goal").
+
detect_liveness_in_goal_2(shorthand(_), _, _, _, _, _) :-
unexpected(this_file, "shorthand in detect_liveness_in_goal_2").
@@ -721,6 +724,9 @@
_, _, _, _, _, _) :-
unexpected(this_file, "foreign_proc in detect_deadness_in_goal_2").
+detect_deadness_in_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _, _, _) :-
+ unexpected(this_file, "detect_deadness_in_goal_2: atomic_goal").
+
detect_deadness_in_goal_2(shorthand(_), _, _, _, _, _, _) :-
unexpected(this_file, "shorthand in detect_deadness_in_goal_2").
@@ -963,6 +969,8 @@
update_liveness_goal(Goal, LiveInfo, !Liveness).
update_liveness_expr(scope(_, Goal), _, LiveInfo, !Liveness) :-
update_liveness_goal(Goal, LiveInfo, !Liveness).
+update_liveness_expr(atomic_goal(_, _, _, _, _, _), _, _, _, _) :-
+ unexpected(this_file, "update_liveness_expr: atomic_goal").
update_liveness_expr(shorthand(_), _, _, _, _) :-
unexpected(this_file, "update_liveness_expr: shorthand").
@@ -1144,6 +1152,9 @@
delay_death_goal(Goal0, Goal, !.BornVars, _, !DelayedDead, VarSet),
!:GoalExpr = scope(Reason, Goal)
;
+ !.GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "delay_death_goal_expr: atomic_goal")
+ ;
!.GoalExpr = shorthand(_),
unexpected(this_file, "delay_death_goal_expr: shorthand")
).
@@ -1398,6 +1409,9 @@
detect_resume_points_in_goal_2(Goal @ call_foreign_proc(_, _, _, _, _, _, _),
Goal, !Liveness, _, _, _).
+detect_resume_points_in_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _,
+ _, _) :-
+ unexpected(this_file, "detect_resume_points_in_goal_2: atomic_goal").
detect_resume_points_in_goal_2(shorthand(_), _, _, _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file,
Index: compiler/loop_inv.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/loop_inv.m,v
retrieving revision 1.42
diff -u -r1.42 loop_inv.m
--- compiler/loop_inv.m 7 Aug 2007 07:09:58 -0000 1.42
+++ compiler/loop_inv.m 1 Oct 2007 02:44:10 -0000
@@ -391,6 +391,9 @@
IGCs = invariant_goal_candidates_keeping_path_candidates(PPId,
ElseGoal, IGCs1).
+invariant_goal_candidates_2(_PPid,
+ hlds_goal(atomic_goal(_, _, _, _, _, _), _GoalInfo), _IGCs) = _ :-
+ unexpected(this_file, "invariant_goal_candidates_2: atomic_goal").
invariant_goal_candidates_2(_PPId,
hlds_goal(shorthand(_), _GoalInfo), _IGCs) = _ :-
unexpected(this_file,
@@ -918,6 +921,10 @@
),
GoalInfo).
+gen_aux_proc_2(_Info, hlds_goal(atomic_goal(_, _, _, _, _, _), _GoalInfo))
+ = _ :-
+ unexpected(this_file, "gen_aux_proc_2: atomic_goal").
+
gen_aux_proc_2(_Info, hlds_goal(shorthand(_), _GoalInfo)) = _ :-
unexpected(this_file, "gen_aux_proc_2/2: shorthand/1 in hlds_goal").
@@ -1050,6 +1057,9 @@
gen_out_proc_2(PPId, CallAux, Else)),
GoalInfo).
+gen_out_proc_2(_PPId, _CallAux, hlds_goal(atomic_goal(_, _, _, _, _, _),
+ _GoalInfo)) = _ :-
+ unexpected(this_file, "gen_out_proc_2: atomic_goal").
gen_out_proc_2(_PPId, _CallAux, hlds_goal(shorthand(_), _GoalInfo)) = _ :-
unexpected(this_file, "gen_out_proc_2/3: shorthand/1 in hlds_goal").
@@ -1156,6 +1166,9 @@
uniquely_used_vars_2(MI, Then) ++
uniquely_used_vars_2(MI, Else).
+uniquely_used_vars_3(_MI, atomic_goal(_, _, _, _, _, _)) = _ :-
+ unexpected(this_file, "uniquely_used_vars_3: atomic_goal").
+
uniquely_used_vars_3(_MI, shorthand(_)) = _ :-
unexpected(this_file, "uniquely_used_vars_3/2: shorthand/1 in hlds_goal").
@@ -1248,6 +1261,9 @@
goal_expr_inputs(_MI, if_then_else(_, _, _, _)) = _ :-
unexpected(this_file, "goal_expr_inputs/2: if_then_else/4 in hlds_goal").
+goal_expr_inputs(_MI, atomic_goal(_, _, _, _, _, _)) = _ :-
+ unexpected(this_file, "goal_expr_inputs/2: atomic_goal/5 in hlds_goal").
+
goal_expr_inputs(_MI, shorthand(_)) = _ :-
unexpected(this_file, "goal_expr_inputs/2: shorthand/1 in hlds_goal").
@@ -1331,6 +1347,9 @@
goal_expr_outputs(_MI, if_then_else(_, _, _, _)) = _ :-
unexpected(this_file, "goal_expr_outputs/2: if_then_else/4 in hlds_goal").
+goal_expr_outputs(_MI, atomic_goal(_, _, _, _, _, _)) = _ :-
+ unexpected(this_file, "goal_expr_outputs/2: atomic_goal/1 in hlds_goal").
+
goal_expr_outputs(_MI, shorthand(_)) = _ :-
unexpected(this_file, "goal_expr_outputs/2: shorthand/1 in hlds_goal").
Index: compiler/make_hlds_warn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_warn.m,v
retrieving revision 1.24
diff -u -r1.24 make_hlds_warn.m
--- compiler/make_hlds_warn.m 7 Aug 2007 07:09:58 -0000 1.24
+++ compiler/make_hlds_warn.m 1 Oct 2007 02:44:10 -0000
@@ -208,6 +208,14 @@
warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
NamesModes, Context, PredCallId, ModuleInfo, !Specs)
;
+ % XXX Need to look at how listed variables should be handled for the
+ % atomic goal.
+ GoalExpr = atomic_goal(_, _, _, _, MainGoal, OrElseGoals),
+ warn_singletons_in_goal(MainGoal, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs),
+ warn_singletons_in_goal_list(OrElseGoals, QuantVars, VarSet,
+ PredCallId, ModuleInfo, !Specs)
+ ;
GoalExpr = shorthand(ShorthandGoal),
warn_singletons_in_goal_2_shorthand(ShorthandGoal, GoalInfo,
QuantVars, VarSet, PredCallId, ModuleInfo, !Specs)
Index: compiler/mark_static_terms.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mark_static_terms.m,v
retrieving revision 1.28
diff -u -r1.28 mark_static_terms.m
--- compiler/mark_static_terms.m 6 Jan 2007 09:23:40 -0000 1.28
+++ compiler/mark_static_terms.m 1 Oct 2007 02:44:10 -0000
@@ -112,6 +112,9 @@
goal_expr_mark_static_terms(Goal @ call_foreign_proc(_, _, _, _, _, _, _),
Goal, !SI).
+goal_expr_mark_static_terms(atomic_goal(_, _, _, _, _, _), _, !SI) :-
+ unexpected(this_file, "goal_expr_mark_static_terms: atomic_goal").
+
goal_expr_mark_static_terms(shorthand(_), _, !SI) :-
% These should have been expanded out by now.
unexpected(this_file, "fill_expr_slots: unexpected shorthand").
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.452
diff -u -r1.452 mercury_compile.m
--- compiler/mercury_compile.m 4 Oct 2007 09:04:42 -0000 1.452
+++ compiler/mercury_compile.m 8 Oct 2007 23:52:17 -0000
@@ -71,6 +71,7 @@
:- import_module transform_hlds.table_gen.
:- import_module transform_hlds.complexity.
:- import_module transform_hlds.lambda.
+:- import_module transform_hlds.stm_expand.
:- import_module transform_hlds.closure_analysis.
:- import_module transform_hlds.termination.
:- import_module transform_hlds.ssdebug.
@@ -2267,6 +2268,8 @@
ClosureAnalysis = yes,
mercury_compile.process_lambdas(Verbose, Stats,
!HLDS, !IO),
+
+ mercury_compile.process_stms(Verbose, Stats, !HLDS, !IO),
mercury_compile.maybe_closure_analysis(Verbose, Stats,
!HLDS, !IO)
;
@@ -2529,6 +2532,9 @@
process_lambdas(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 110, "lambda", !DumpInfo, !IO),
+ process_stms(Verbose, Stats, !HLDS, !IO),
+ maybe_dump_hlds(!.HLDS, 113, "stm", !DumpInfo, !IO),
+
expand_equiv_types_hlds(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 115, "equiv_types", !DumpInfo, !IO),
@@ -3601,6 +3607,18 @@
%-----------------------------------------------------------------------------%
+:- pred process_stms(bool::in, bool::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+process_stms(Verbose, Stats, !HLDS, !IO) :-
+ maybe_write_string(Verbose, "% Transforming stm expressions...", !IO),
+ maybe_flush_output(Verbose, !IO),
+ stm_process_module(!HLDS),
+ maybe_write_string(Verbose, " done.\n", !IO),
+ maybe_report_stats(Stats, !IO).
+
+%-----------------------------------------------------------------------------%
+
:- pred expand_equiv_types_hlds(bool::in, bool::in,
module_info::in, module_info::out, io::di, io::uo) is det.
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.319
diff -u -r1.319 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 27 Aug 2007 06:22:13 -0000 1.319
+++ compiler/mercury_to_mercury.m 9 Oct 2007 03:06:50 -0000
@@ -2774,6 +2774,39 @@
mercury_output_newline(Indent, !IO),
io.write_string(")", !IO).
+mercury_output_goal_2(atomic_expr(Outer, Inner, _, MainExpr,
+ OrElseExprs), VarSet, Indent, !IO) :-
+ io.write_string("atomic [outer(", !IO),
+ (
+ Outer = atomic_state_var(OVar),
+ io.write_string("!", !IO),
+ mercury_output_var(VarSet, no, OVar, !IO)
+ ;
+ Outer = atomic_var_pair(OuterDI, OuterUO),
+ mercury_output_var(VarSet, no, OuterDI, !IO),
+ io.write_string(", ", !IO),
+ mercury_output_var(VarSet, no, OuterUO, !IO)
+ ),
+ io.write_string("), inner(", !IO),
+ (
+ Inner = atomic_state_var(IVar),
+ io.write_string("!", !IO),
+ mercury_output_var(VarSet, no, IVar, !IO)
+ ;
+ Inner = atomic_var_pair(InnerDI, InnerUO),
+ mercury_output_var(VarSet, no, InnerDI, !IO),
+ io.write_string(", ", !IO),
+ mercury_output_var(VarSet, no, InnerUO, !IO)
+ ),
+ io.write_string(")] (", !IO),
+
+ Indent1 = Indent + 1,
+ mercury_output_newline(Indent1, !IO),
+ mercury_output_orelse_goals([MainExpr | OrElseExprs], VarSet, Indent1,
+ !IO),
+ mercury_output_newline(Indent, !IO),
+ io.write_string(")", !IO).
+
mercury_output_goal_2(Expr, VarSet, Indent, !IO) :-
Expr = trace_expr(MaybeCompileTime, MaybeRunTime, MaybeIO, MutableVars,
Goal),
@@ -3096,6 +3129,29 @@
%-----------------------------------------------------------------------------%
+:- pred mercury_output_orelse_goals(goals::in, prog_varset::in, int::in,
+ io::di, io::uo) is det.
+
+mercury_output_orelse_goals(Goals, VarSet, Indent, !IO) :-
+ (
+ Goals = []
+ ;
+ Goals = [Goal0 | GoalTails],
+ (
+ GoalTails = [],
+ mercury_output_goal(Goal0, VarSet, Indent + 1, !IO)
+ ;
+ GoalTails = [_|_],
+ mercury_output_goal(Goal0, VarSet, Indent + 1, !IO),
+ mercury_output_newline(Indent, !IO),
+ io.write_string("orelse", !IO),
+ mercury_output_newline(Indent, !IO),
+ mercury_output_orelse_goals(GoalTails, VarSet, Indent, !IO)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
mercury_output_pragma_foreign_decl(Lang, IsLocal, ForeignDeclString, !IO) :-
mercury_format_pragma_foreign_decl(Lang, IsLocal, ForeignDeclString, !IO).
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.130
diff -u -r1.130 middle_rec.m
--- compiler/middle_rec.m 31 Jul 2007 01:56:38 -0000 1.130
+++ compiler/middle_rec.m 1 Oct 2007 02:44:12 -0000
@@ -195,6 +195,7 @@
).
contains_only_builtins_expr(call_foreign_proc(_, _, _, _, _, _, _)) = no.
contains_only_builtins_expr(generic_call(_, _, _, _)) = no.
+contains_only_builtins_expr(atomic_goal(_, _, _, _, _, _)) = no.
contains_only_builtins_expr(shorthand(_)) = no.
:- func contains_only_builtins_cases(list(case)) = bool.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.205
diff -u -r1.205 ml_code_gen.m
--- compiler/ml_code_gen.m 21 Aug 2007 15:50:40 -0000 1.205
+++ compiler/ml_code_gen.m 1 Oct 2007 02:44:12 -0000
@@ -2256,6 +2256,9 @@
OuterContext, Decls, Statements, !Info)
).
+ml_gen_goal_expr(atomic_goal(_, _, _, _, _, _), _, _, _, _, !Info) :-
+ unexpected(this_file, "ml_gen_goal_expr: unexpected atomic_goal").
+
ml_gen_goal_expr(shorthand(_), _, _, _, _, !Info) :-
% these should have been expanded out by now
unexpected(this_file, "ml_gen_goal_expr: unexpected shorthand").
Index: compiler/mode_constraint_robdd.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_constraint_robdd.m,v
retrieving revision 1.12
diff -u -r1.12 mode_constraint_robdd.m
--- compiler/mode_constraint_robdd.m 6 Jan 2007 10:56:15 -0000 1.12
+++ compiler/mode_constraint_robdd.m 1 Oct 2007 02:44:12 -0000
@@ -375,6 +375,11 @@
io.write_char('f').
dump_goal_path_step(step_later) -->
io.write_char('l').
+dump_goal_path_step(step_atomic_main) -->
+ io.write_char('a').
+dump_goal_path_step(step_atomic_orelse(N)) -->
+ io.write_char('o'),
+ io.write_int(N).
robdd_to_dot(Constraint, ProgVarSet, Info, FileName) -->
robdd_to_dot(Constraint ^ robdd, P, FileName),
Index: compiler/mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_constraints.m,v
retrieving revision 1.42
diff -u -r1.42 mode_constraints.m
--- compiler/mode_constraints.m 7 Aug 2007 07:09:59 -0000 1.42
+++ compiler/mode_constraints.m 1 Oct 2007 02:44:12 -0000
@@ -441,6 +441,15 @@
number_robdd_variables_in_goal(InstGraph, NonLocals, Occurring,
Goal0, Goal, !RInfo).
number_robdd_variables_in_goal_2(InstGraph, _, _, NonLocals, Occurring,
+ atomic_goal(GoalType, Inner, Outer, Vars, MainGoal0, OrElseGoals0),
+ atomic_goal(GoalType, Inner, Outer, Vars, MainGoal, OrElseGoals),
+ !RInfo) :-
+ number_robdd_variables_in_goal(InstGraph, NonLocals, OccMain,
+ MainGoal0, MainGoal, !RInfo),
+ number_robdd_variables_in_goals(InstGraph, NonLocals, OccOrElse,
+ OrElseGoals0, OrElseGoals, !RInfo),
+ Occurring = OccMain `set.union` OccOrElse.
+number_robdd_variables_in_goal_2(InstGraph, _, _, NonLocals, Occurring,
if_then_else(Vs, Cond0, Then0, Else0),
if_then_else(Vs, Cond, Then, Else), !RInfo) :-
number_robdd_variables_in_goal(InstGraph, NonLocals, OccCond,
@@ -1431,6 +1440,24 @@
goal_constraints_2(_, _, _, _, call_foreign_proc(_, _, _, _, _, _, _),
_, _, _, _, _) :-
sorry(this_file, "goal_constraints_2: foreign_proc NYI").
+
+goal_constraints_2(GoalPath, NonLocals, Vars, CanSucceed,
+ atomic_goal(GoalType, Outer, Inner, OutVars, MainGoal0, OrElseGoals0),
+ atomic_goal(GoalType, Outer, Inner, OutVars, MainGoal, OrElseGoals),
+ !Constraint, !GCInfo) :-
+ Goals0 = [MainGoal0 | OrElseGoals0],
+ disj_constraints(NonLocals, CanSucceed, !Constraint, Goals0, Goals,
+ [], DisjunctPaths, !GCInfo),
+ list.foldl2((pred(V::in, Cons0::in, Cons::out, in, out) is det -->
+ get_var(V `at` GoalPath, Vgp),
+ list.foldl2((pred(Path::in, C0::in, C::out, in, out) is det -->
+ get_var(V `at` Path, VPath),
+ { C = C0 ^ eq_vars(Vgp, VPath) }
+ ), DisjunctPaths, Cons0, Cons)
+ ), set.to_sorted_list(Vars), !Constraint, !GCInfo),
+ MainGoal = list.det_head(Goals),
+ OrElseGoals = list.det_tail(Goals).
+
goal_constraints_2(_, _, _, _, shorthand(_), _, _, _, _, _) :-
sorry(this_file, "goal_constraints_2: shorthand").
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.120
diff -u -r1.120 mode_errors.m
--- compiler/mode_errors.m 27 Aug 2007 06:22:14 -0000 1.120
+++ compiler/mode_errors.m 1 Oct 2007 02:44:12 -0000
@@ -36,7 +36,8 @@
:- type merge_context
---> disj
- ; if_then_else.
+ ; if_then_else
+ ; stm_atomic.
:- type merge_error
---> merge_error(prog_var, list(mer_inst)).
@@ -539,6 +540,7 @@
merge_context_to_string(disj) = "disjunction".
merge_context_to_string(if_then_else) = "if-then-else".
+merge_context_to_string(stm_atomic) = "atomic".
%-----------------------------------------------------------------------------%
@@ -565,6 +567,10 @@
Reason = var_lock_trace_goal,
ReasonStr = "attempt to bind a non-local variable inside a trace goal."
;
+ Reason = var_lock_atomic_goal,
+ ReasonStr = "attempt to bind outer state variables inside an " ++
+ "atomic goal."
+ ;
Reason = var_lock_par_conj,
ReasonStr = "attempt to bind a non-local variable" ++
" inside more than one parallel conjunct."
@@ -602,6 +608,11 @@
[words("A trace goal is only allowed to bind variables"),
words("which are local to the trace goal."), nl]
;
+ Reason = var_lock_atomic_goal,
+ VerbosePieces =
+ [words("An atomic goal may not use the state variables"),
+ words("belonging to the outer scope."), nl]
+ ;
Reason = var_lock_par_conj,
VerbosePieces =
[words("A nonlocal variable of a parallel conjunction"),
Index: compiler/mode_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_info.m,v
retrieving revision 1.95
diff -u -r1.95 mode_info.m
--- compiler/mode_info.m 14 Aug 2007 01:52:28 -0000 1.95
+++ compiler/mode_info.m 1 Oct 2007 02:44:12 -0000
@@ -69,6 +69,7 @@
; var_lock_if_then_else
; var_lock_lambda(pred_or_func)
; var_lock_trace_goal
+ ; var_lock_atomic_goal
; var_lock_par_conj.
% Specify how to process goals - using either modes.m or unique_modes.m.
Index: compiler/mode_ordering.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_ordering.m,v
retrieving revision 1.24
diff -u -r1.24 mode_ordering.m
--- compiler/mode_ordering.m 7 Sep 2007 15:08:17 -0000 1.24
+++ compiler/mode_ordering.m 1 Oct 2007 02:44:12 -0000
@@ -334,6 +334,17 @@
combine_mode_vars_sets(Else ^ hlds_goal_info, !GoalInfo).
+mode_order_goal_2(Goal0, Goal, !GoalInfo, !MOI) :-
+ Goal0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ mode_order_goal(MainGoal0, MainGoal, !MOI),
+
+ list.map_foldl(mode_order_goal, OrElseGoals0, OrElseGoals, !MOI),
+ mode_order_disj(OrElseGoals, !GoalInfo),
+
+ Goal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals).
+
+
mode_order_goal_2(Goal0, _, !GoalInfo, !MOI) :-
Goal0 = call_foreign_proc(_, _, _, _, _, _, _),
unexpected(this_file, "mode_order_goal_2: pragma_foreign_code NYI").
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.199
diff -u -r1.199 mode_util.m
--- compiler/mode_util.m 7 Aug 2007 07:10:00 -0000 1.199
+++ compiler/mode_util.m 9 Oct 2007 03:07:13 -0000
@@ -1115,6 +1115,17 @@
ExtraArgsInstMapDelta, large_base, InstMapDelta)
).
+recompute_instmap_delta_2(Atomic, atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal0, OrElseGoals0), GoalInfo, atomic_goal(GoalType, Outer,
+ Inner, Vars, MainGoal, OrElseGoals), VarTypes, InstMap,
+ InstMapDelta, !RI) :-
+ Goals0 = [MainGoal0 | OrElseGoals0],
+ NonLocals = goal_info_get_nonlocals(GoalInfo),
+ recompute_instmap_delta_disj(Atomic, Goals0, Goals, VarTypes, InstMap,
+ NonLocals, InstMapDelta, !RI),
+ MainGoal = list.det_head(Goals),
+ OrElseGoals = list.det_tail(Goals).
+
recompute_instmap_delta_2(_, shorthand(_), _, _, _, _, _, !RI) :-
% these should have been expanded out by now
unexpected(this_file,
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.360
diff -u -r1.360 modes.m
--- compiler/modes.m 14 Aug 2007 01:52:29 -0000 1.360
+++ compiler/modes.m 9 Oct 2007 03:07:34 -0000
@@ -1669,6 +1669,63 @@
mode_info_unset_call_context(!ModeInfo),
mode_checkpoint(exit, "pragma_foreign_code", !ModeInfo, !IO).
+modecheck_goal_expr(atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0), GoalInfo0, GoalExpr, !ModeInfo, !IO) :-
+
+ mode_checkpoint(enter, "atomic", !ModeInfo, !IO),
+
+ (
+ Outer = atomic_state_var(_),
+ sorry(this_file, "atomic_state_var not yet supported")
+ ;
+ Outer = atomic_var_pair(OuterDI, OuterUO),
+
+ OuterVars0 = set.init,
+ set.insert(OuterVars0, OuterDI, OuterVars1),
+ set.insert(OuterVars1, OuterUO, _OuterVars)
+ ),
+
+ (
+ Inner = atomic_state_var(_Var),
+ sorry(this_file, "atomic_state_var not yet supported")
+ ;
+ Inner = atomic_var_pair(_InnerDI, _InnerUO)
+
+ ),
+
+ AtomicGoalList0 = [MainGoal0 | OrElseGoals0],
+
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+
+ % XXX STM: Locking the outer variables will generate an error message
+ % durring mode analysis of the sub goal because of the calls to
+ % "stm_outer_to_inner_io" and "stm_inner_to_outer_io". I don't think
+ % this is a major problem as the uniqueness states of the outer and
+ % inner variables are enforced by these calls anyway.
+
+% mode_info_lock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
+ modecheck_orelse_list(AtomicGoalList0, AtomicGoalList1, InstMapList0,
+ !ModeInfo, !IO),
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+% mode_info_unlock_vars(var_lock_atomic_goal, OuterVars, !ModeInfo),
+
+ % XXX - Handling of solver vars
+ handle_solver_vars_in_disjs(set.to_sorted_list(NonLocals),
+ VarTypes, AtomicGoalList1, AtomicGoalList2, InstMapList0,
+ InstMapList, !ModeInfo),
+ AtomicGoalList = AtomicGoalList2,
+
+ instmap_merge(NonLocals, InstMapList, stm_atomic, !ModeInfo),
+
+ MainGoal = list.det_head(AtomicGoalList),
+ OrElseGoals = list.det_tail(AtomicGoalList),
+
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals),
+
+ mode_checkpoint(exit, "atomic", !ModeInfo, !IO).
+
+
modecheck_goal_expr(shorthand(_), _, _, !ModeInfo, !IO) :-
% these should have been expanded out by now
unexpected(this_file, "modecheck_goal_expr: unexpected shorthand").
@@ -2777,6 +2834,23 @@
modecheck_set_var_inst(Var,
bound(unique, [bound_functor(ConsId, ArgInsts)]), no, !ModeInfo).
+% The uniqueness of the Inner And Outer variables are handled
+% by the addition of calls to the fake predicates "stm_inner_to_outer_io" and
+% "stm_outer_to_inner_io" durring the construction of the HLDS. These
+% calls are removed when atomic goals are expanded.
+%
+:- pred modecheck_orelse_list(list(hlds_goal)::in, list(hlds_goal)::out,
+ list(instmap)::out, mode_info::in, mode_info::out, io::di, io::uo) is det.
+
+modecheck_orelse_list([], [], [], !ModeInfo, !IO).
+modecheck_orelse_list([Goal0 | Goals0], [Goal | Goals], [InstMap | InstMaps],
+ !ModeInfo, !IO) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap0),
+ modecheck_goal(Goal0, Goal, !ModeInfo, !IO),
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ mode_info_set_instmap(InstMap0, !ModeInfo),
+ modecheck_orelse_list(Goals0, Goals, InstMaps, !ModeInfo, !IO).
+
%-----------------------------------------------------------------------------%
% Calculate the argument number offset that needs to be passed to
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.158
diff -u -r1.158 module_qual.m
--- compiler/module_qual.m 20 Aug 2007 03:36:02 -0000 1.158
+++ compiler/module_qual.m 1 Oct 2007 02:44:12 -0000
@@ -532,6 +532,12 @@
process_assert(G, Symbols, Success).
process_assert(trace_expr(_C, _R, _I, _M, G) - _, Symbols, Success) :-
process_assert(G, Symbols, Success).
+process_assert(atomic_expr(_, _, _, MainGoal, OrElseGoals) - _, Symbols,
+ Success) :-
+ process_assert(MainGoal, SymbolsMainGoal, SuccessMainGoal),
+ process_assert_list(OrElseGoals, SymbolsOrElseGoals, SuccessOrElseGoals),
+ list.append(SymbolsMainGoal, SymbolsOrElseGoals, Symbols),
+ bool.and(SuccessMainGoal, SuccessOrElseGoals, Success).
process_assert(implies_expr(GA, GB) - _, Symbols, Success) :-
process_assert(GA, SymbolsA, SuccessA),
process_assert(GB, SymbolsB, SuccessB),
@@ -589,6 +595,27 @@
Success = no
).
+
+ % process_assert(G, SNs, B)
+ %
+ % Performs process_assert on a list of goals.
+ %
+:- pred process_assert_list(list(goal)::in, list(sym_name)::out,
+ bool::out) is det.
+
+process_assert_list(ExprList, Symbols, Success) :-
+ (
+ ExprList = [],
+ Symbols = [],
+ Success = yes
+ ;
+ ExprList = [Expr | Rest],
+ process_assert(Expr, SymbolsE, SuccessE),
+ process_assert_list(Rest, SymbolsR, SuccessR),
+ list.append(SymbolsE, SymbolsR, Symbols),
+ bool.and(SuccessE, SuccessR, Success)
+ ).
+
% term_qualified_symbols(T, S)
%
% Given a term, T, return the list of all the sym_names, S, in the
Index: compiler/ordering_mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ordering_mode_constraints.m,v
retrieving revision 1.16
diff -u -r1.16 ordering_mode_constraints.m
--- compiler/ordering_mode_constraints.m 7 Aug 2007 07:10:01 -0000 1.16
+++ compiler/ordering_mode_constraints.m 9 Oct 2007 03:07:41 -0000
@@ -816,6 +816,11 @@
Goals = [CondGoal, ThenGoal, ElseGoal],
list.foldl(dump_goal_goal_paths(Indent), Goals, !IO).
+dump_goal_expr_goal_paths(Indent, GoalExpr, !IO) :-
+ GoalExpr = atomic_goal(_, _, _, _, MainGoal, OrElseGoals),
+ Goals = [MainGoal | OrElseGoals],
+ list.foldl(dump_goal_goal_paths(Indent), Goals, !IO).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/pd_cost.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pd_cost.m,v
retrieving revision 1.34
diff -u -r1.34 pd_cost.m
--- compiler/pd_cost.m 7 Aug 2007 07:10:01 -0000 1.34
+++ compiler/pd_cost.m 1 Oct 2007 02:44:13 -0000
@@ -111,6 +111,9 @@
InputArgs = Arity // 2, % rough
Cost = Cost1 + cost_of_call + cost_of_reg_assign * InputArgs.
+goal_expr_cost(atomic_goal(_, _, _, _, _, _), _, _) :-
+ unexpected(this_file, "atomic_goal: unexpected atomic_goal").
+
goal_expr_cost(shorthand(_), _, _) :-
% these should have been expanded out by now
unexpected(this_file, "goal_cost: unexpected shorthand").
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.321
diff -u -r1.321 polymorphism.m
--- compiler/polymorphism.m 20 Aug 2007 03:36:04 -0000 1.321
+++ compiler/polymorphism.m 1 Oct 2007 02:44:13 -0000
@@ -1098,6 +1098,14 @@
),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal0, OrElseGoals0),
+ polymorphism_process_goal(MainGoal0, MainGoal, !Info),
+ polymorphism_process_goal_list(OrElseGoals0, OrElseGoals, !Info),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal, OrElseGoals),
+ Goal = hlds_goal(GoalExpr, GoalInfo0)
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "process_goal_expr: unexpected shorthand")
).
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.120
diff -u -r1.120 post_typecheck.m
--- compiler/post_typecheck.m 7 Aug 2007 07:10:02 -0000 1.120
+++ compiler/post_typecheck.m 1 Oct 2007 02:44:13 -0000
@@ -634,6 +634,10 @@
in_interface_check(ModuleInfo, PredInfo, Then, !Specs),
in_interface_check(ModuleInfo, PredInfo, Else, !Specs)
;
+ GoalExpr = atomic_goal(_, _, _, _, MainGoal, OrElseGoals),
+ in_interface_check(ModuleInfo, PredInfo, MainGoal, !Specs),
+ in_interface_check_list(ModuleInfo, PredInfo, OrElseGoals, !Specs)
+ ;
GoalExpr = shorthand(ShorthandGoal),
in_interface_check_shorthand(ModuleInfo, PredInfo, ShorthandGoal,
!Specs)
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.196
diff -u -r1.196 prog_data.m
--- compiler/prog_data.m 28 Sep 2007 03:17:13 -0000 1.196
+++ compiler/prog_data.m 1 Oct 2007 02:44:13 -0000
@@ -966,6 +966,10 @@
trace_state_var :: prog_var
).
+:- type atomic_component_state
+ ---> atomic_state_var(prog_var)
+ ; atomic_var_pair(prog_var, prog_var).
+
% These type equivalences are for the type of program variables
% and associated structures.
%
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.52
diff -u -r1.52 prog_io_goal.m
--- compiler/prog_io_goal.m 30 May 2007 03:49:18 -0000 1.52
+++ compiler/prog_io_goal.m 9 Oct 2007 03:07:59 -0000
@@ -379,6 +379,28 @@
SubGoalErrors = get_any_errors1(MaybeSubGoal),
MaybeGoal = error1(ParamsErrors ++ SubGoalErrors)
).
+parse_goal_2("atomic", [ParamsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
+ parse_atomic_params(Context, ParamsTerm, MaybeParams),
+ parse_atomic_subexpr(SubTerm, MaybeSubGoals, !VarSet),
+ (
+ MaybeParams = ok1(Params),
+ MaybeSubGoals = ok2(MainGoal, OrElseGoals)
+ ->
+ convert_atomic_params(ParamsTerm, Params, MaybeComponents),
+ (
+ MaybeComponents = ok3(Outer, Inner, MaybeOutputVars),
+ GoalExpr = atomic_expr(Outer, Inner, MaybeOutputVars, MainGoal,
+ OrElseGoals),
+ MaybeGoal = ok1(GoalExpr - Context)
+ ;
+ MaybeComponents = error3(Errors),
+ MaybeGoal = error1(Errors)
+ )
+ ;
+ ParamsErrors = get_any_errors1(MaybeParams),
+ SubGoalErrors = get_any_errors2(MaybeSubGoals),
+ MaybeGoal = error1(ParamsErrors ++ SubGoalErrors)
+ ).
parse_goal_2("promise_equivalent_solutions", [VarsTerm, SubTerm], Context,
MaybeGoal, !VarSet) :-
parse_vars_and_state_vars(VarsTerm, MaybeVars),
@@ -631,8 +653,7 @@
MaybeHeadComponent = ok1(HeadComponent),
MaybeTailComponentsTerms = ok1(TailComponentsTerms)
->
- MaybeComponentsTerms = ok1([HeadComponent |
- TailComponentsTerms])
+ MaybeComponentsTerms = ok1([HeadComponent | TailComponentsTerms])
;
HeadErrors = get_any_errors1(MaybeHeadComponent),
TailErrors = get_any_errors1(MaybeTailComponentsTerms),
@@ -1049,6 +1070,317 @@
%-----------------------------------------------------------------------------%
+:- type atomic_component
+ ---> atomic_component_inner(atomic_component_state)
+ ; atomic_component_outer(atomic_component_state)
+ ; atomic_component_vars(list(prog_var)).
+
+:- pred parse_atomic_params(context::in, term::in,
+ maybe1(assoc_list(atomic_component, term))::out) is det.
+
+parse_atomic_params(Context, Term, MaybeComponentsTerms) :-
+ ( Term = term.functor(term.atom("[]"), [], _) ->
+ MaybeComponentsTerms = ok1([])
+ ; Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _) ->
+ parse_atomic_component(Term, HeadTerm, MaybeHeadComponent),
+ parse_atomic_params(Context, TailTerm, MaybeTailComponentsTerms),
+ (
+ MaybeHeadComponent = ok1(HeadComponent),
+ MaybeTailComponentsTerms = ok1(TailComponentsTerms)
+ ->
+ MaybeComponentsTerms = ok1([HeadComponent | TailComponentsTerms])
+ ;
+ HeadErrors = get_any_errors1(MaybeHeadComponent),
+ TailErrors = get_any_errors1(MaybeTailComponentsTerms),
+ MaybeComponentsTerms = error1(HeadErrors ++ TailErrors)
+ )
+ ;
+ (
+ Term = term.functor(_, _, _),
+ Msg = "invalid atomic goal parameter",
+ MaybeComponentsTerms = error1([Msg - Term])
+ ;
+ Term = term.variable(_, _),
+ Msg = "expected atomic goal parameter, found variable",
+ ErrorTerm = term.functor(term.atom(""), [], Context),
+ MaybeComponentsTerms = error1([Msg - ErrorTerm])
+ )
+ ).
+
+:- pred parse_atomic_subterm(string::in, term::in, term::in,
+ maybe1(atomic_component_state)::out) is det.
+
+parse_atomic_subterm(Name, ErrorTerm, Term, MaybeComponentTerm) :-
+ (
+ Term = term.functor(_, SubTerms, _),
+ ( SubTerms = [SubTerm] ->
+ parse_atomic_component_state(Name, SubTerm, MaybeCompState),
+ (
+ MaybeCompState = ok1(Component),
+ MaybeComponentTerm = ok1(Component)
+ ;
+ MaybeCompState = error1(Errors),
+ MaybeComponentTerm = error1(Errors)
+ )
+ ;
+ SubTerms = [SubTermA, SubTermB] ->
+ parse_atomic_component_pair(Name, SubTermA, SubTermB,
+ MaybeCompState),
+ (
+ MaybeCompState = ok1(Component),
+ MaybeComponentTerm = ok1(Component)
+ ;
+ MaybeCompState = error1(Errors),
+ MaybeComponentTerm = error1(Errors)
+ )
+ ;
+ Msg = Name ++ " takes exactly one argument, " ++
+ "which should be a state variable " ++
+ "or a pair of variables",
+ MaybeComponentTerm = error1([Msg - Term])
+ )
+ ;
+ Term = term.variable(_, _),
+ Msg = "expected atomic goal parameter, found variable",
+ MaybeComponentTerm = error1([Msg - ErrorTerm])
+ ).
+
+:- pred parse_atomic_component(term::in, term::in,
+ maybe1(pair(atomic_component, term))::out) is det.
+
+parse_atomic_component(ErrorTerm, Term, MaybeComponentTerm) :-
+ (
+ Term = term.functor(Functor, SubTerms, _),
+ ( Functor = term.atom(Atom) ->
+ ( Atom = "outer" ->
+ parse_atomic_subterm(Atom, ErrorTerm, Term,
+ MaybeComponentSubTerm),
+ (
+ MaybeComponentSubTerm = ok1(CompTerm),
+ Component = atomic_component_outer(CompTerm),
+ MaybeComponentTerm = ok1(Component - Term)
+ ;
+ MaybeComponentSubTerm = error1(Errors),
+ MaybeComponentTerm = error1(Errors)
+ )
+ ; Atom = "inner" ->
+ parse_atomic_subterm(Atom, ErrorTerm, Term,
+ MaybeComponentSubTerm),
+ (
+ MaybeComponentSubTerm = ok1(CompTerm),
+ Component = atomic_component_inner(CompTerm),
+ MaybeComponentTerm = ok1(Component - Term)
+ ;
+ MaybeComponentSubTerm = error1(Errors),
+ MaybeComponentTerm = error1(Errors)
+ )
+ ; Atom = "vars" ->
+ ( SubTerms = [SubTerm] ->
+ parse_vars(SubTerm, MaybeVars),
+ (
+ MaybeVars = ok1(Vars),
+ list.map(term.coerce_var, Vars, ProgVars),
+ Component = atomic_component_vars(ProgVars),
+ MaybeComponentTerm = ok1(Component - Term)
+ ;
+ MaybeVars = error1(Errors),
+ MaybeComponentTerm = error1(Errors)
+ )
+ ;
+ Msg = Atom ++ " takes exactly one argument, " ++
+ "which should be a list of variable names",
+ MaybeComponentTerm = error1([Msg - Term])
+ )
+ ;
+ Msg = "invalid atomic goal parameter",
+ MaybeComponentTerm = error1([Msg - Term])
+ )
+ ;
+ Msg = "invalid atomic goal parameter",
+ MaybeComponentTerm = error1([Msg - Term])
+ )
+ ;
+ Term = term.variable(_, _),
+ Msg = "expected atomic goal parameter, found variable",
+ MaybeComponentTerm = error1([Msg - ErrorTerm])
+ ).
+
+:- pred parse_atomic_component_state(string::in, term::in,
+ maybe1(atomic_component_state)::out) is det.
+
+parse_atomic_component_state(Scope, Term, MaybeState) :-
+ (
+ Term = term.functor(term.atom("!"), [term.variable(Var, _)], _)
+ ->
+ term.coerce_var(Var, ProgVar),
+ MaybeState = ok1(atomic_state_var(ProgVar))
+ ;
+ raise_atomic_component_state_error(Scope, Msg),
+ MaybeState = error1([Msg - Term])
+ ).
+
+:- pred parse_atomic_component_pair(string::in, term::in,
+ term::in, maybe1(atomic_component_state)::out) is det.
+
+parse_atomic_component_pair(Scope, TermA, TermB, MaybeState) :-
+ (
+ TermA = term.variable(VarA, _),
+ TermB = term.variable(VarB, _)
+ ->
+ term.coerce_var(VarA, ProgVarA),
+ term.coerce_var(VarB, ProgVarB),
+ MaybeState = ok1(atomic_var_pair(ProgVarA, ProgVarB))
+ ;
+ raise_atomic_component_state_error(Scope, Msg),
+ MaybeState = error1([Msg - TermA])
+ ).
+
+:- pred raise_atomic_component_state_error(string::in, string::out) is det.
+
+raise_atomic_component_state_error(Scope, Msg) :-
+ Msg = "The argument of " ++ Scope ++ "should contain " ++
+ "either a state variable or a pair of variables".
+
+
+:- pred convert_atomic_params(term::in,
+ assoc_list(atomic_component, term)::in,
+ maybe3(atomic_component_state, atomic_component_state,
+ maybe(list(prog_var)))::out) is det.
+
+convert_atomic_params(ErrorTerm, Components, MaybeParams) :-
+ convert_atomic_params_2(ErrorTerm, Components, no, no, no, [],
+ MaybeParams).
+
+:- pred convert_atomic_params_2(term::in,
+ assoc_list(atomic_component, term)::in,
+ maybe(atomic_component_state)::in,
+ maybe(atomic_component_state)::in,
+ maybe(list(prog_var))::in,
+ assoc_list(string, term)::in,
+ maybe3(atomic_component_state, atomic_component_state,
+ maybe(list(prog_var)))::out) is det.
+
+convert_atomic_params_2(ErrorTerm, [], MaybeOuter, MaybeInner, MaybeVars,
+ Errors, MaybeParams) :-
+ (
+ Errors = [],
+ (
+ MaybeOuter = yes(Outer),
+ MaybeInner = yes(Inner),
+ MaybeParams = ok3(Outer, Inner, MaybeVars)
+ ;
+ MaybeOuter = yes(_),
+ MaybeInner = no,
+ Msg = "atomic goal is missing " ++
+ "a specification of the inner STM state",
+ MaybeParams = error3([Msg - ErrorTerm])
+ ;
+ MaybeOuter = no,
+ MaybeInner = yes(_),
+ Msg = "atomic goal is missing " ++
+ "a specification of the outer STM state",
+ MaybeParams = error3([Msg - ErrorTerm])
+ ;
+ MaybeOuter = no,
+ MaybeInner = no,
+ Msg = "atomic goal is missing " ++
+ "a specification of both the outer and inner STM state",
+ MaybeParams = error3([Msg - ErrorTerm])
+ )
+ ;
+ Errors = [_ | _],
+ MaybeParams = error3(Errors)
+ ).
+convert_atomic_params_2(ErrorTerm, [Component - Term | ComponentsTerms],
+ !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Errors, MaybeParams) :-
+ (
+ Component = atomic_component_outer(Outer),
+ (
+ !.MaybeOuter = no,
+ !:MaybeOuter = yes(Outer)
+ ;
+ !.MaybeOuter = yes(_),
+ Msg = "duplicate outer atomic parameter",
+ !:Errors = !.Errors ++ [Msg - Term]
+ )
+ ;
+ Component = atomic_component_inner(Inner),
+ (
+ !.MaybeInner = no,
+ !:MaybeInner = yes(Inner)
+ ;
+ !.MaybeInner = yes(_),
+ Msg = "duplicate inner atomic parameter",
+ !:Errors = !.Errors ++ [Msg - Term]
+ )
+ ;
+ Component = atomic_component_vars(Vars),
+ (
+ !.MaybeVars = no,
+ !:MaybeVars = yes(Vars)
+ ;
+ !.MaybeVars = yes(_),
+ Msg = "duplicate io trace parameter",
+ !:Errors = !.Errors ++ [Msg - Term]
+ )
+ ),
+ convert_atomic_params_2(ErrorTerm, ComponentsTerms,
+ !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Errors, MaybeParams).
+
+
+:- pred parse_atomic_subexpr(term::in, maybe2(goal, goals)::out,
+ prog_varset::in, prog_varset::out) is det.
+
+parse_atomic_subexpr(Term, MaybeSubExpr, !VarSet) :-
+ parse_atomic_subgoals_as_list(Term, MaybeGoalList, !VarSet),
+ ( MaybeGoalList = ok1(GoalList) ->
+ (
+ GoalList = [],
+ Msg = "atomic goal must have a subgoal",
+ MaybeSubExpr = error2([Msg - Term])
+ ;
+ GoalList = [MainSubGoalExpr | OrElseAlternativeSubExpr],
+ MaybeSubExpr = ok2(MainSubGoalExpr, OrElseAlternativeSubExpr)
+ )
+ ;
+ GoalListErrors = get_any_errors1(MaybeGoalList),
+ MaybeSubExpr = error2(GoalListErrors)
+ ).
+
+
+:- pred parse_atomic_subgoals_as_list(term::in, maybe1(list(goal))::out,
+ prog_varset::in, prog_varset::out) is det.
+
+parse_atomic_subgoals_as_list(Term, MaybeGoals, !VarSet) :-
+ (
+ Term = term.functor(term.atom("or_else"), [LeftGoal, RightGoal], _)
+ ->
+ parse_atomic_subgoals_as_list(LeftGoal, MaybeLeftGoalList, !VarSet),
+ parse_atomic_subgoals_as_list(RightGoal, MaybeRightGoalList, !VarSet),
+ (
+ MaybeLeftGoalList = ok1(LeftGoalList),
+ MaybeRightGoalList = ok1(RightGoalList)
+ ->
+ MaybeGoals = ok1(LeftGoalList ++ RightGoalList)
+ ;
+ LeftErrors = get_any_errors1(MaybeLeftGoalList),
+ RightErrors = get_any_errors1(MaybeRightGoalList),
+ MaybeGoals = error1(LeftErrors ++ RightErrors)
+ )
+ ;
+ parse_goal(Term, MaybeSubGoal, !VarSet),
+ (
+ MaybeSubGoal = ok1(SubGoal)
+ ->
+ MaybeGoals = ok1([SubGoal])
+ ;
+ SubGoalErrors = get_any_errors1(MaybeSubGoal),
+ MaybeGoals = error1(SubGoalErrors)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred parse_lambda_arg(term::in, prog_term::out, mer_mode::out) is semidet.
parse_lambda_arg(Term, ArgTerm, Mode) :-
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.29
diff -u -r1.29 prog_item.m
--- compiler/prog_item.m 20 Aug 2007 03:36:04 -0000 1.29
+++ compiler/prog_item.m 1 Oct 2007 02:44:13 -0000
@@ -739,6 +739,23 @@
texpr_mutable_vars :: list(trace_mutable_var),
texpr_goal :: goal
)
+ ; atomic_expr(
+ % Subgoals of the atomic goal are parsed into the following
+ % datatype. During the creation of the parse tree, all
+ % subterms of the "orelse" operator are flattened and placed
+ % into a list. If this is the case, the first "orelse"
+ % alternative is stored in "main_goal" whilst the other
+ % alternatives are stored in "orelse_alternatives". If there
+ % are no "or_else" operators within the atomic subgoal,
+ % the subgoal is stored in "main_goal" whilst the
+ % "orelse_alternatives" list remains empty.
+
+ aexpr_outer :: atomic_component_state,
+ aexpr_inner :: atomic_component_state,
+ aexpr_output_vars :: maybe(list(prog_var)),
+ aexpr_main_goal :: goal,
+ aexpr_orelse_goals :: goals
+ )
% implications
; implies_expr(goal, goal)
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.55
diff -u -r1.55 prog_rep.m
--- compiler/prog_rep.m 12 Sep 2007 06:21:08 -0000 1.55
+++ compiler/prog_rep.m 1 Oct 2007 02:44:13 -0000
@@ -290,6 +290,10 @@
AtomicBytes, _),
Bytes = [goal_type_to_byte(goal_foreign)] ++
vars_to_byte_list(Info, ArgVars) ++ AtomicBytes.
+goal_expr_to_byte_list(atomic_goal(_, _, _, _, _, _), _, _, _,
+ !StackInfo, _) :-
+ unexpected(this_file, "goal_expr_to_byte_list: unexpected atomic_goal").
+
goal_expr_to_byte_list(shorthand(_), _, _, _, !StackInfo, _) :-
% these should have been expanded out by now
unexpected(this_file, "goal_expr_to_byte_list: unexpected shorthand").
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.41
diff -u -r1.41 prog_type.m
--- compiler/prog_type.m 25 Sep 2007 04:56:41 -0000 1.41
+++ compiler/prog_type.m 1 Oct 2007 02:44:13 -0000
@@ -299,6 +299,7 @@
:- func sample_typeclass_info_type = mer_type.
:- func comparison_result_type = mer_type.
:- func io_state_type = mer_type.
+:- func stm_atomic_type = mer_type.
:- func region_type = mer_type.
% Succeed iff the given variable is of region_type.
@@ -912,6 +913,10 @@
Module = mercury_std_lib_module_name(unqualified("io")),
Name = qualified(Module, "state").
+stm_atomic_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("stm_builtin")),
+ Name = qualified(Module, "stm").
+
region_type = defined_type(Name, [], kind_star) :-
Module = mercury_region_builtin_module,
Name = qualified(Module, "region").
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.101
diff -u -r1.101 prog_util.m
--- compiler/prog_util.m 28 Sep 2007 03:17:13 -0000 1.101
+++ compiler/prog_util.m 1 Oct 2007 02:44:13 -0000
@@ -459,6 +459,22 @@
Mutables0, Mutables),
rename_in_goal(OldVar, NewVar, Goal0, Goal).
rename_in_goal_expr(OldVar, NewVar,
+ atomic_expr(InVars0, OutVars0, MaybeVars0, MainExpr0, OrElseExpr0),
+ atomic_expr(InVars, OutVars, MaybeVars, MainExpr, OrElseExpr)) :-
+ rename_in_atomic_varlist(OldVar, NewVar, InVars0, InVars),
+ rename_in_atomic_varlist(OldVar, NewVar, OutVars0, OutVars),
+ (
+ MaybeVars0 = no,
+ MaybeVars = no
+ ;
+ MaybeVars0 = yes(TransVars0),
+ list.map(rename_in_var(OldVar, NewVar),
+ TransVars0, TransVars),
+ MaybeVars = yes(TransVars)
+ ),
+ rename_in_goal(OldVar, NewVar, MainExpr0, MainExpr),
+ list.map(rename_in_goal(OldVar, NewVar), OrElseExpr0, OrElseExpr).
+rename_in_goal_expr(OldVar, NewVar,
implies_expr(GoalA0, GoalB0),
implies_expr(GoalA, GoalB)) :-
rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
@@ -490,6 +506,21 @@
term.substitute(TermA0, OldVar, term.variable(NewVar, context_init), TermA),
term.substitute(TermB0, OldVar, term.variable(NewVar, context_init), TermB).
+:- pred rename_in_atomic_varlist(prog_var::in, prog_var::in,
+ atomic_component_state::in, atomic_component_state::out) is det.
+
+rename_in_atomic_varlist(OldVar, NewVar, Comp0, Comp) :-
+ (
+ Comp0 = atomic_state_var(SVar0),
+ rename_in_var(OldVar, NewVar, SVar0, SVar),
+ Comp = atomic_state_var(SVar)
+ ;
+ Comp0 = atomic_var_pair(IVar0, OVar0),
+ rename_in_var(OldVar, NewVar, IVar0, IVar),
+ rename_in_var(OldVar, NewVar, OVar0, OVar),
+ Comp = atomic_var_pair(IVar, OVar)
+ ).
+
:- pred rename_in_trace_mutable_var(prog_var::in, prog_var::in,
trace_mutable_var::in, trace_mutable_var::out) is det.
Index: compiler/prop_mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prop_mode_constraints.m,v
retrieving revision 1.18
diff -u -r1.18 prop_mode_constraints.m
--- compiler/prop_mode_constraints.m 7 Aug 2007 07:10:03 -0000 1.18
+++ compiler/prop_mode_constraints.m 9 Oct 2007 03:08:07 -0000
@@ -331,6 +331,15 @@
unexpected(this_file, "switch")
;
!.GoalExpr = unify(_, _, _, _, _)
+ ;
+ !.GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ ensure_unique_arguments_in_goal(MainGoal0, MainGoal, !SeenSoFar,
+ !Varset, !Vartypes),
+ list.map_foldl3(ensure_unique_arguments_in_goal, OrElseGoals0,
+ OrElseGoals, !SeenSoFar, !Varset, !Vartypes),
+ !:GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals)
;
!.GoalExpr = disj(Goals0),
list.map_foldl3(ensure_unique_arguments_in_goal, Goals0, Goals,
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.114
diff -u -r1.114 purity.m
--- compiler/purity.m 7 Aug 2007 07:10:03 -0000 1.114
+++ compiler/purity.m 1 Oct 2007 02:44:13 -0000
@@ -611,16 +611,11 @@
!:Info = !.Info ^ implicit_purity := ImplicitPurity0,
Purity = PromisedPurity
;
- Reason = promise_solutions(_, _),
- compute_goal_purity(Goal0, Goal, Purity, ContainsTrace, !Info)
- ;
- Reason = commit(_),
- compute_goal_purity(Goal0, Goal, Purity, ContainsTrace, !Info)
- ;
- Reason = barrier(_),
- compute_goal_purity(Goal0, Goal, Purity, ContainsTrace, !Info)
- ;
- Reason = from_ground_term(_),
+ ( Reason = promise_solutions(_, _)
+ ; Reason = commit(_)
+ ; Reason = barrier(_)
+ ; Reason = from_ground_term(_)
+ ),
compute_goal_purity(Goal0, Goal, Purity, ContainsTrace, !Info)
;
Reason = trace_goal(_, _, _, _, _),
@@ -667,6 +662,25 @@
ForeignProc = ForeignProc0,
Purity = get_purity(Attributes)
).
+compute_expr_purity(AtomicGoal0, AtomicGoal, _, Purity,
+ ContainsTrace, !Info) :-
+ AtomicGoal0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ compute_goal_purity(MainGoal0, MainGoal, Purity1, ContainsTrace1, !Info),
+ compute_goals_purity(OrElseGoals0, OrElseGoals, purity_pure, Purity2,
+ contains_no_trace_goal, ContainsTrace2, !Info),
+ worst_purity(Purity1, Purity2) = Purity,
+ (
+ ( ContainsTrace1 = contains_trace_goal
+ ; ContainsTrace2 = contains_trace_goal
+ )
+ ->
+ ContainsTrace = contains_trace_goal
+ ;
+ ContainsTrace = contains_no_trace_goal
+ ),
+ AtomicGoal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals).
compute_expr_purity(shorthand(_), _, _, _, _, !Info) :-
% These should have been expanded out by now.
unexpected(this_file, "compute_expr_purity: unexpected shorthand").
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.121
diff -u -r1.121 quantification.m
--- compiler/quantification.m 28 Sep 2007 03:17:13 -0000 1.121
+++ compiler/quantification.m 9 Oct 2007 03:08:26 -0000
@@ -593,6 +593,27 @@
list.append(Vars, ExtraVars, AllVars),
implicitly_quantify_atomic_goal(AllVars, !Info).
+implicitly_quantify_goal_quant_info_2(Expr0, Expr, _, !Info) :-
+ Expr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0, OrElseGoals0),
+
+ % XXX STM: Because of the calls to "stm_inner_to_outer_io" and
+ % "stm_outer_to_inner_io", the outer variables are implicitly added
+ % to the list of non-local variables.
+
+ NonLocalVarSets0 = [],
+ AllAtomicGoals0 = [MainGoal0 | OrElseGoals0],
+ implicitly_quantify_disj(AllAtomicGoals0, AllAtomicGoals, !Info,
+ NonLocalVarSets0, NonLocalVarSets),
+
+ union_list(NonLocalVarSets, NonLocalVars),
+ set_nonlocals(NonLocalVars, !Info),
+
+ MainGoal = list.det_head(AllAtomicGoals),
+ OrElseGoals = list.det_tail(AllAtomicGoals),
+
+ Expr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals).
+
+
implicitly_quantify_goal_quant_info_2(Expr0, Expr, GoalInfo0, !Info) :-
Expr0 = shorthand(ShorthandGoal),
implicitly_quantify_goal_quant_info_2_shorthand(ShorthandGoal, Expr,
@@ -1251,6 +1272,12 @@
list.append(Vars, ExtraVars, AllVars),
insert_list(!.Set, AllVars, !:Set).
+goal_vars_2(NonLocalsToRecompute,
+ atomic_goal(_GoalType, _Outer, _Inner, _Vars, MainGoal, OrElseGoals),
+ !Set, !LambdaSet) :-
+ disj_vars(NonLocalsToRecompute, [MainGoal | OrElseGoals],
+ !Set, !LambdaSet).
+
goal_vars_2(NonLocalsToRecompute, shorthand(ShorthandGoal), !Set,
!LambdaSet) :-
goal_vars_2_shorthand(NonLocalsToRecompute, ShorthandGoal, !Set,
Index: compiler/rbmm.actual_region_arguments.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.actual_region_arguments.m,v
retrieving revision 1.4
diff -u -r1.4 rbmm.actual_region_arguments.m
--- compiler/rbmm.actual_region_arguments.m 6 Sep 2007 12:45:24 -0000 1.4
+++ compiler/rbmm.actual_region_arguments.m 1 Oct 2007 02:44:13 -0000
@@ -188,6 +188,11 @@
record_actual_region_arguments_goal(ModuleInfo, PPId, RptaInfoTable,
ConstantRTable, DeadRTable, BornRTable, Goal, !ActualRegionArgProc).
+record_actual_region_arguments_expr(atomic_goal(_, _, _, _, _, _), _, _, _,
+ _, _, _, _, !ActualRegionArgProc) :-
+ unexpected(this_file,
+ "record_actual_region_arguments_expr: unexpected atomic_goal").
+
record_actual_region_arguments_expr(shorthand(_), _, _, _, _, _, _, _,
!ActualRegionArgProc) :-
unexpected(this_file,
Index: compiler/rbmm.add_rbmm_goal_infos.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.add_rbmm_goal_infos.m,v
retrieving revision 1.1
diff -u -r1.1 rbmm.add_rbmm_goal_infos.m
--- compiler/rbmm.add_rbmm_goal_infos.m 6 Sep 2007 12:45:24 -0000 1.1
+++ compiler/rbmm.add_rbmm_goal_infos.m 1 Oct 2007 02:44:13 -0000
@@ -348,6 +348,10 @@
goal_info_set_maybe_rbmm(yes(IteRbmmInfo), !Info).
collect_rbmm_goal_info_goal_expr(_, _, _, _, _, _, _, !Expr, !Info) :-
+ !.Expr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "collect_rbmm_goal_info_expr: atomic_goal unexpected").
+collect_rbmm_goal_info_goal_expr(_, _, _, _, _, _, _, !Expr, !Info) :-
!.Expr = shorthand(_),
unexpected(this_file,
"collect_rbmm_goal_info_goal_expr: shorthand unexpected").
Index: compiler/rbmm.condition_renaming.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.condition_renaming.m,v
retrieving revision 1.5
diff -u -r1.5 rbmm.condition_renaming.m
--- compiler/rbmm.condition_renaming.m 23 Jul 2007 05:06:13 -0000 1.5
+++ compiler/rbmm.condition_renaming.m 1 Oct 2007 02:44:13 -0000
@@ -305,6 +305,12 @@
LRBeforeProc, LRAfterProc, ResurRenamingProc, ResurRenamingAnnoProc,
Else, !NonLocalRegionProc).
+collect_non_local_and_in_cond_regions_expr(_, _, _, _, _,
+ atomic_goal(_, _, _, _, _, _), !NonLocalRegionProc,
+ !InCondRegionsProc) :-
+ unexpected(this_file, "collect_non_local_and_in_cond_regions_expr: "
+ ++ "unexpected atomic_goal").
+
collect_non_local_and_in_cond_regions_expr(_, _, _, _, _, shorthand(_),
!NonLocalRegionProc, !InCondRegionsProc) :-
unexpected(this_file, "collect_non_local_and_in_cond_regions_expr: "
@@ -520,6 +526,7 @@
; Expr = disj([])
; Expr = call_foreign_proc(_, _, _, _, _, _, _)
; Expr = generic_call(_, _, _, _)
+ ; Expr = atomic_goal(_, _, _, _, _, _)
; Expr = shorthand(_)
),
unexpected(this_file,
@@ -689,6 +696,7 @@
; Expr = disj([])
; Expr = call_foreign_proc(_, _, _, _, _, _, _)
; Expr = generic_call(_, _, _, _)
+ ; Expr = atomic_goal(_, _, _, _, _, _)
; Expr = shorthand(_)
),
unexpected(this_file,
@@ -830,6 +838,11 @@
collect_ite_renaming_goal(IteRenamedRegionProc, Graph, Goal,
!IteRenamingProc).
+collect_ite_renaming_expr(atomic_goal(_, _, _, _, _, _), _, _,
+ !IteRenamingProc) :-
+ unexpected(this_file,
+ "collect_ite_renaming_expr: atomic_goal not handled").
+
collect_ite_renaming_expr(shorthand(_), _, _, !IteRenamingProc) :-
unexpected(this_file, "collect_ite_renaming_expr: shorthand not handled").
@@ -949,6 +962,7 @@
; Expr = disj([])
; Expr = call_foreign_proc(_, _, _, _, _, _, _)
; Expr = generic_call(_, _, _, _)
+ ; Expr = atomic_goal(_, _, _, _, _, _)
; Expr = shorthand(_)
),
unexpected(this_file,
Index: compiler/rbmm.execution_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.execution_path.m,v
retrieving revision 1.5
diff -u -r1.5 rbmm.execution_path.m
--- compiler/rbmm.execution_path.m 23 Jul 2007 05:06:13 -0000 1.5
+++ compiler/rbmm.execution_path.m 1 Oct 2007 02:44:13 -0000
@@ -162,6 +162,7 @@
; Expr = call_foreign_proc(_, _, _, _, _, _, _)
; Expr = generic_call(_, _, _, _)
; Expr = shorthand(_)
+ ; Expr = atomic_goal(_, _, _, _, _, _)
),
unexpected(this_file,
"collect_execution_path_in_compound_goal: encountered atomic or"
Index: compiler/rbmm.points_to_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.points_to_analysis.m,v
retrieving revision 1.6
diff -u -r1.6 rbmm.points_to_analysis.m
--- compiler/rbmm.points_to_analysis.m 23 Jul 2007 05:06:14 -0000 1.6
+++ compiler/rbmm.points_to_analysis.m 1 Oct 2007 02:44:13 -0000
@@ -167,6 +167,9 @@
intra_analyse_goal(Then, !RptaInfo),
intra_analyse_goal(Else, !RptaInfo).
+intra_analyse_goal_expr(atomic_goal(_, _, _, _, _, _), _, _) :-
+ unexpected(this_file, "intra_analyse_goal_expr: unexpected atomic_goal").
+
intra_analyse_goal_expr(shorthand(_), _, _) :-
unexpected(this_file, "intra_analyse_goal_expr: shorthand not handled").
@@ -480,6 +483,11 @@
sorry(this_file,
"inter_analyse_goal_expr: foreign code not handled").
+inter_analyse_goal_expr(atomic_goal(_, _, _, _, _, _), _, _, _,
+ !FPTable, !RptaInfo) :-
+ unexpected(this_file,
+ "inter_analyse_goal_expr: shorthand goal not handled").
+
inter_analyse_goal_expr(shorthand(_), _, _, _, !FPTable, !RptaInfo) :-
unexpected(this_file,
"inter_analyse_goal_expr: shorthand goal not handled").
Index: compiler/rbmm.region_transformation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.region_transformation.m,v
retrieving revision 1.4
diff -u -r1.4 rbmm.region_transformation.m
--- compiler/rbmm.region_transformation.m 6 Sep 2007 12:45:24 -0000 1.4
+++ compiler/rbmm.region_transformation.m 1 Oct 2007 02:44:13 -0000
@@ -481,6 +481,7 @@
; !.GoalExpr = switch(_, _, _)
; !.GoalExpr = scope(_, _)
; !.GoalExpr = shorthand(_)
+ ; !.GoalExpr = atomic_goal(_, _, _, _, _, _)
),
unexpected(this_file,
"region_transform_goal_expr: encounter compound goal").
@@ -562,6 +563,7 @@
; !.GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
; !.GoalExpr = conj(_, [])
; !.GoalExpr = disj([])
+ ; !.GoalExpr = atomic_goal(_, _, _, _, _, _)
),
unexpected(this_file, "region_transform_compound_goal: " ++
"encounter shorthand or atomic goal")
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.75
diff -u -r1.75 saved_vars.m
--- compiler/saved_vars.m 7 Aug 2007 07:10:04 -0000 1.75
+++ compiler/saved_vars.m 9 Oct 2007 03:08:34 -0000
@@ -158,6 +158,9 @@
),
Goal = Goal0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "saved_vars_in_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
% these should have been expanded out by now
unexpected(this_file,
@@ -418,6 +421,10 @@
IsNonLocal, !SlotInfo),
Goals = [Goal1 | Goals1]
;
+ Goal0Expr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "saved_vars_delay_goal: unexpected atomic_goal")
+ ;
Goal0Expr = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file,
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.217
diff -u -r1.217 simplify.m
--- compiler/simplify.m 28 Sep 2007 03:17:13 -0000 1.217
+++ compiler/simplify.m 9 Oct 2007 03:11:32 -0000
@@ -1748,6 +1748,28 @@
)
).
+% XXX STM: At the moment the inner goals are not simplified as there is
+% a chance that the outer and inner variables will change which will
+% cause problems durring expansion of STM constructs. This will be
+% fixed eventually.
+%
+simplify_goal_2(atomic_goal(GoalType, Outer, Inner, Vars,
+ MainGoal0, OrElseGoals0), Goal, GoalInfo, GoalInfo, !Info, !IO) :-
+ MainGoal = MainGoal0,
+ OrElseGoals = OrElseGoals0,
+% simplify_goal(MainGoal0, MainGoal, !Info, !IO),
+% simplify_or_else_goals(OrElseGoals0, OrElseGoals, !Info, !IO),
+ Goal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals).
+
+:- pred simplify_or_else_goals(hlds_goals::in, hlds_goals::out,
+ simplify_info::in, simplify_info::out, io::di, io::uo) is det.
+
+simplify_or_else_goals([], [], !Info, !IO).
+simplify_or_else_goals([Goal0 | Goals0], [Goal | Goals], !Info, !IO) :-
+ simplify_goal(Goal0, Goal, !Info, !IO),
+ simplify_or_else_goals(Goals0, Goals, !Info, !IO).
+
+
:- func make_arg_always_boxed(foreign_arg) = foreign_arg.
make_arg_always_boxed(Arg) = Arg ^ arg_box_policy := always_boxed.
@@ -3116,6 +3138,16 @@
goal_contains_trace(SubGoal0, SubGoal, ContainsTrace),
GoalExpr = scope(Reason, SubGoal)
;
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ goal_contains_trace(MainGoal0, MainGoal, MainContainsTrace),
+ goal_list_contains_trace(OrElseGoals0, OrElseGoals,
+ contains_no_trace_goal, OrElseContainsTrace),
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals),
+ ContainsTrace = worst_contains_trace(MainContainsTrace,
+ OrElseContainsTrace)
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "goal_contains_trace: shorthand")
),
@@ -3546,6 +3578,17 @@
:- pred simplify_info_post_branch_update(simplify_info::in, simplify_info::in,
simplify_info::out) is det.
+% XXX STM: Please check this, zs.
+will_flush(atomic_goal(_, _, _, _, _MainGoal, _OrElseGoals), BeforeAfter)
+ = WillFlush :-
+ (
+ BeforeAfter = before,
+ WillFlush = yes
+ ;
+ BeforeAfter = after,
+ WillFlush = no
+ ).
+
simplify_info_post_branch_update(PreBranchInfo, PostBranchInfo0, Info) :-
simplify_info_get_instmap(PreBranchInfo, InstMap),
simplify_info_set_instmap(InstMap, PostBranchInfo0, PostBranchInfo1),
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.53
diff -u -r1.53 size_prof.m
--- compiler/size_prof.m 7 Aug 2007 07:10:04 -0000 1.53
+++ compiler/size_prof.m 1 Oct 2007 02:44:13 -0000
@@ -472,6 +472,10 @@
process_goal(SomeGoal0, SomeGoal, !Info),
GoalExpr = scope(Reason, SomeGoal)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "size_prof.process_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "size_prof.process_goal: shorthand")
),
Index: compiler/smm_common.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/smm_common.m,v
retrieving revision 1.3
diff -u -r1.3 smm_common.m
--- compiler/smm_common.m 7 Aug 2007 07:10:05 -0000 1.3
+++ compiler/smm_common.m 1 Oct 2007 02:44:13 -0000
@@ -175,6 +175,11 @@
io.write_char('f').
dump_goal_path_step(step_later) -->
io.write_char('l').
+dump_goal_path_step(step_atomic_main) -->
+ io.write_char('a').
+dump_goal_path_step(step_atomic_orelse(N)) -->
+ io.write_char('o'),
+ io.write_int(N).
%-----------------------------------------------------------------------------%
:- end_module smm_common.
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/store_alloc.m,v
retrieving revision 1.105
diff -u -r1.105 store_alloc.m
--- compiler/store_alloc.m 7 Aug 2007 07:10:05 -0000 1.105
+++ compiler/store_alloc.m 1 Oct 2007 02:44:13 -0000
@@ -239,6 +239,9 @@
store_alloc_in_goal_2(Goal @ call_foreign_proc(_, _, _, _, _, _, _), Goal,
!Liveness, !LastLocns, _, _, _).
+store_alloc_in_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _, _, _, _, _) :-
+ unexpected(this_file, "store_alloc_in_goal_2: unexpected atomic_goal").
+
store_alloc_in_goal_2(shorthand(_), _, _, _, _, _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "store_alloc_in_goal_2: unexpected shorthand").
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.62
diff -u -r1.62 stratify.m
--- compiler/stratify.m 7 Sep 2007 15:08:18 -0000 1.62
+++ compiler/stratify.m 1 Oct 2007 02:44:13 -0000
@@ -228,6 +228,14 @@
).
first_order_check_goal(generic_call(_Var, _Vars, _Modes, _Det), _GInfo,
_Negated, _WholeScc, _ThisPredProcId, _Error, !ModuleInfo, !IO).
+first_order_check_goal(atomic_goal(_GType, _Outer, _Inner, _Vars, MainGoal,
+ OrElseGoals), _GInfo, Negated, WholeScc, ThisPredProcId, Error,
+ !ModuleInfo, !IO) :-
+ MainGoal = hlds_goal(MainGoalExpr, MainGoalInfo),
+ first_order_check_goal(MainGoalExpr, MainGoalInfo, Negated, WholeScc,
+ ThisPredProcId, Error, !ModuleInfo, !IO),
+ first_order_check_goal_list(OrElseGoals, Negated, WholeScc,
+ ThisPredProcId, Error, !ModuleInfo, !IO).
first_order_check_goal(shorthand(_), _, _, _, _, _, !ModuleInfo, !IO) :-
% these should have been expanded out by now
unexpected(this_file, "first_order_check_goal: unexpected shorthand").
@@ -348,6 +356,14 @@
higher_order_check_goal(unify(_Var, _RHS, _Mode, _Uni, _Context), _GoalInfo,
_Negated, _WholeScc, _ThisPredProcId, _HighOrderLoops, _Error,
!ModuleInfo, !IO).
+higher_order_check_goal(atomic_goal(_GType, _Outer, _Inner, _Vars, MainGoal,
+ OrElseGoals), _GoalInfo, Negated, WholeScc, ThisPredProcId,
+ HighOrderLoops, Error, !ModuleInfo, !IO) :-
+ MainGoal = hlds_goal(MainGoalExpr, MainGoalInfo),
+ higher_order_check_goal(MainGoalExpr, MainGoalInfo, Negated, WholeScc,
+ ThisPredProcId, HighOrderLoops, Error, !ModuleInfo, !IO),
+ higher_order_check_goal_list(OrElseGoals, Negated, WholeScc,
+ ThisPredProcId, HighOrderLoops, Error, !ModuleInfo, !IO).
higher_order_check_goal(plain_call(_CPred, _CProc, _Args, _Builtin, _UC, Sym),
GoalInfo, _Negated, _WholeScc, ThisPredProcId, HighOrderLoops,
Error, !ModuleInfo, !IO) :-
@@ -759,6 +775,11 @@
check_goal1(GoalExpr, !Calls, !HasAT, !CallsHO).
check_goal1(call_foreign_proc(_Attrib, _CPred, _CProc, _, _, _, _),
!Calls, !HasAT, !CallsHO).
+check_goal1(atomic_goal(_GoalType, _Outer, _Inner, _Vars, MainGoal,
+ OrElseGoals), !Calls, !HasAT, !CallsHO) :-
+ MainGoal = hlds_goal(MainGoalExpr, _),
+ check_goal1(MainGoalExpr, !Calls, !HasAT, !CallsHO),
+ check_goal_list(OrElseGoals, !Calls, !HasAT, !CallsHO).
check_goal1(shorthand(_), _, _, _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "check_goal1: unexpected shorthand").
@@ -842,6 +863,12 @@
get_called_procs(GoalExpr, !Calls).
get_called_procs(call_foreign_proc(_Attrib, _CPred, _CProc, _, _, _, _),
!Calls).
+get_called_procs(atomic_goal(_GType, _Outer, _Inner, _Vars, MainGoal,
+ OrElseGoals), !Calls) :-
+ MainGoal = hlds_goal(MainGoalExpr, _),
+ get_called_procs(MainGoalExpr, !Calls),
+ check_goal_list(OrElseGoals, !Calls).
+
get_called_procs(shorthand(_), !Calls) :-
% These should have been expanded out by now.
unexpected(this_file, "get_called_procs: unexpected shorthand").
Index: compiler/structure_reuse.direct.choose_reuse.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.direct.choose_reuse.m,v
retrieving revision 1.10
diff -u -r1.10 structure_reuse.direct.choose_reuse.m
--- compiler/structure_reuse.direct.choose_reuse.m 25 Sep 2007 04:56:41 -0000 1.10
+++ compiler/structure_reuse.direct.choose_reuse.m 1 Oct 2007 02:44:13 -0000
@@ -626,6 +626,10 @@
compute_match_table_goal_list(Background, DeadCellTable, Cont,
!Table, !IO)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(choose_reuse.this_file,
+ "compute_match_table: atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(choose_reuse.this_file, "compute_match_table: " ++
"shorthand goal.")
@@ -832,6 +836,10 @@
find_match_in_goal_2(Background, ElseGoal, Match0, MatchElse),
average_match([!.Match, MatchElse], !:Match)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(choose_reuse.this_file,
+ "find_match_in_goal: atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(choose_reuse.this_file, "find_match_in_goal: " ++
"shorthand goal.")
@@ -1130,6 +1138,10 @@
GoalExpr = if_then_else(A, CondGoal, ThenGoal, ElseGoal),
GoalInfo = GoalInfo0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(choose_reuse.this_file,
+ "annotate_reuses: atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(choose_reuse.this_file, "annotate_reuses: " ++
"shorthand goal.")
@@ -1404,6 +1416,9 @@
GoalExpr = if_then_else(A, CondGoal, ThenGoal, ElseGoal),
GoalInfo = GoalInfo0
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(choose_reuse.this_file, "check_cc: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(choose_reuse.this_file, "check_cc: " ++
"shorthand goal.")
Index: compiler/structure_reuse.direct.detect_garbage.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.direct.detect_garbage.m,v
retrieving revision 1.10
diff -u -r1.10 structure_reuse.direct.detect_garbage.m
--- compiler/structure_reuse.direct.detect_garbage.m 7 Aug 2007 07:10:05 -0000 1.10
+++ compiler/structure_reuse.direct.detect_garbage.m 1 Oct 2007 02:44:13 -0000
@@ -146,6 +146,10 @@
proc(ForeignPredId, ForeignProcId), Attributes, Context,
!.SharingAs)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(detect_garbage.this_file,
+ "determine_dead_deconstructions_2: unexpected atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(detect_garbage.this_file,
"determine_dead_deconstructions_2: shorthand goal.")
Index: compiler/structure_reuse.indirect.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.indirect.m,v
retrieving revision 1.12
diff -u -r1.12 structure_reuse.indirect.m
--- compiler/structure_reuse.indirect.m 7 Aug 2007 07:10:06 -0000 1.12
+++ compiler/structure_reuse.indirect.m 1 Oct 2007 02:44:13 -0000
@@ -381,6 +381,10 @@
proc(ForeignPredId, ForeignProcId), Attributes, Context,
!.AnalysisInfo ^ sharing_as)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "indirect_reuse_analyse_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "indirect_reuse_analyse_goal: shorthand goal.")
).
Index: compiler/structure_reuse.lbu.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.lbu.m,v
retrieving revision 1.9
diff -u -r1.9 structure_reuse.lbu.m
--- compiler/structure_reuse.lbu.m 7 Aug 2007 07:10:06 -0000 1.9
+++ compiler/structure_reuse.lbu.m 1 Oct 2007 02:44:13 -0000
@@ -162,6 +162,10 @@
set.union(LBUT, LBUE, !:LBU),
!:Expr = if_then_else(Vars, Cond, Then, Else)
;
+ !.Expr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file,
+ "backward_use_in_goal_2: unexpected atomic_goal")
+ ;
!.Expr = shorthand(_),
unexpected(this_file, "backward_use_in_goal_2: shorthand goal.")
).
Index: compiler/structure_reuse.versions.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.versions.m,v
retrieving revision 1.7
diff -u -r1.7 structure_reuse.versions.m
--- compiler/structure_reuse.versions.m 17 May 2007 03:52:51 -0000 1.7
+++ compiler/structure_reuse.versions.m 1 Oct 2007 02:44:13 -0000
@@ -270,6 +270,9 @@
GoalExpr0 = call_foreign_proc(_Attrs, _ForeignPredId, _ForeignProcId,
_Args, _ExtraArgs, _MaybeTraceRuntimeCond, _Impl)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "process_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "process_goal: shorthand goal.")
).
Index: compiler/structure_sharing.analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_sharing.analysis.m,v
retrieving revision 1.23
diff -u -r1.23 structure_sharing.analysis.m
--- compiler/structure_sharing.analysis.m 7 Aug 2007 07:10:06 -0000 1.23
+++ compiler/structure_sharing.analysis.m 9 Oct 2007 03:11:52 -0000
@@ -406,6 +406,9 @@
proc(ForeignPredId, ForeignProcId), Attributes, Context,
!.SharingAs)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "analyse_goal: unexpected atomic_goal")
+ ;
GoalExpr = shorthand(_),
unexpected(this_file, "analyse_goal: shorthand goal.")
).
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.135
diff -u -r1.135 switch_detection.m
--- compiler/switch_detection.m 7 Aug 2007 07:10:06 -0000 1.135
+++ compiler/switch_detection.m 1 Oct 2007 02:44:13 -0000
@@ -253,6 +253,14 @@
Goal0 = call_foreign_proc(_, _, _, _, _, _, _),
Goal = Goal0
;
+ Goal0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ detect_switches_in_goal(ModuleInfo, VarTypes, InstMap0, MainGoal0,
+ MainGoal, !Requant),
+ detect_switches_in_orelse(ModuleInfo, VarTypes, InstMap0, OrElseGoals0,
+ OrElseGoals, !Requant),
+ Goal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals)
+ ;
Goal0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "detect_switches_in_goal_2: shorthand")
@@ -395,6 +403,17 @@
detect_switches_in_conj(ModuleInfo, VarTypes, InstMap1, Goals0, Goals,
!Requant).
+:- pred detect_switches_in_orelse(module_info::in, vartypes::in, instmap::in,
+ list(hlds_goal)::in, list(hlds_goal)::out, bool::in, bool::out) is det.
+
+detect_switches_in_orelse(_, _, _, [], [], !Requant).
+detect_switches_in_orelse(ModuleInfo, VarTypes, InstMap,
+ [Goal0 | Goals0], [Goal | Goals], !Requant) :-
+ detect_switches_in_goal(ModuleInfo, VarTypes, InstMap, Goal0,
+ Goal, !Requant),
+ detect_switches_in_orelse(ModuleInfo, VarTypes, InstMap, Goals0,
+ Goals, !Requant).
+
%-----------------------------------------------------------------------------%
% partition_disj(Goals, Var, GoalInfo, VarTypes, ModuleInfo, Left, Cases):
Index: compiler/tabling_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tabling_analysis.m,v
retrieving revision 1.9
diff -u -r1.9 tabling_analysis.m
--- compiler/tabling_analysis.m 19 Jan 2007 07:04:32 -0000 1.9
+++ compiler/tabling_analysis.m 1 Oct 2007 02:44:13 -0000
@@ -338,6 +338,9 @@
Goal = call_foreign_proc(Attributes, _, _, _, _, _, _),
Result = get_mm_tabling_status_from_attributes(Attributes),
MaybeAnalysisStatus = yes(optimal).
+check_goal_for_mm_tabling_2(_, _, atomic_goal(_, _, _, _, _, _), _, _, _,
+ !ModuleInfo, !IO) :-
+ sorry(this_file, "check_goal_for_mm_tabling_2: atomic_goal").
check_goal_for_mm_tabling_2(_, _, shorthand(_), _, _, _, !ModuleInfo, !IO) :-
unexpected(this_file,
"shorthand goal encountered during mm tabling analysis.").
@@ -655,6 +658,8 @@
annotate_goal_2(_, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = call_foreign_proc(Attributes, _, _, _, _, _, _),
Status = get_mm_tabling_status_from_attributes(Attributes).
+annotate_goal_2(_, atomic_goal(_, _, _, _, _, _), _, _, _, _, _, _) :-
+ unexpected(this_file, "annotate_goal_2: unexpected atomic_goal").
annotate_goal_2(_, shorthand(_), _, _, _, _, _, _) :-
unexpected(this_file, "shorthand goal").
Index: compiler/term_constr_build.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_build.m,v
retrieving revision 1.18
diff -u -r1.18 term_constr_build.m
--- compiler/term_constr_build.m 7 Aug 2007 07:10:06 -0000 1.18
+++ compiler/term_constr_build.m 1 Oct 2007 02:44:13 -0000
@@ -497,6 +497,9 @@
AbstractGoal = term_primitive(polyhedron.universe, [], []),
info_update_ho_info(Context, !Info).
+build_abstract_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _) :-
+ unexpected(this_file, "build_abstract_goal_2: unexpected atomic_goal").
+
% shorthand/1 goals ought to have been transformed away by
% the time we get round to termination analysis.
%
Index: compiler/term_pass1.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_pass1.m,v
retrieving revision 1.37
diff -u -r1.37 term_pass1.m
--- compiler/term_pass1.m 27 Aug 2007 06:22:15 -0000 1.37
+++ compiler/term_pass1.m 1 Oct 2007 02:44:13 -0000
@@ -390,6 +390,9 @@
check_goal_expr_non_term_calls(_, _, Goal, _, !Errors, !ModuleInfo, !IO) :-
% XXX This looks incomplete - juliensf.
Goal = call_foreign_proc(_, _, _, _, _, _, _).
+check_goal_expr_non_term_calls(_, _, atomic_goal(_, _, _, _, _, _), _,
+ _, _, _, _, _, _) :-
+ sorry(this_file, "check_goal_expr_non_term_calls: atomic_goal").
check_goal_expr_non_term_calls(_, _, shorthand(_), _, _, _, _, _, _, _) :-
unexpected(this_file,
"shorthand goal encountered during termination analysis.").
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.56
diff -u -r1.56 term_traversal.m
--- compiler/term_traversal.m 27 Aug 2007 06:22:15 -0000 1.56
+++ compiler/term_traversal.m 1 Oct 2007 02:44:13 -0000
@@ -349,6 +349,8 @@
true
).
+traverse_goal_2(atomic_goal(_, _, _, _, _, _), _, _, _, _, _, _, _, _) :-
+ sorry(this_file, "traverse_goal_2: atomic_goal").
traverse_goal_2(shorthand(_), _, _, _, _, _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "traverse_goal_2/5: shorthand goal.").
Index: compiler/trailing_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trailing_analysis.m,v
retrieving revision 1.27
diff -u -r1.27 trailing_analysis.m
--- compiler/trailing_analysis.m 20 Aug 2007 03:36:06 -0000 1.27
+++ compiler/trailing_analysis.m 1 Oct 2007 02:44:14 -0000
@@ -450,6 +450,10 @@
GoalExpr = call_foreign_proc(Attributes, _, _, _, _, _, _),
Result = attributes_imply_trail_mod(Attributes),
MaybeAnalysisStatus = yes(optimal).
+check_goal_for_trail_mods_2(_, _, atomic_goal(_, _, _, _, _, _), _, _, _,
+ !ModuleInfo, !IO) :-
+ unexpected(this_file,
+ "check_goal_for_trail_mods_2: unexpected atomic_goal").
check_goal_for_trail_mods_2(_, _, shorthand(_), _, _, _, !ModuleInfo, !IO) :-
unexpected(this_file,
"shorthand goal encountered during trail usage analysis.").
@@ -969,6 +973,8 @@
annotate_goal_2(_, _, !Goal, Status, !ModuleInfo, !IO) :-
!.Goal = call_foreign_proc(Attributes, _, _, _, _, _, _),
Status = attributes_imply_trail_mod(Attributes).
+annotate_goal_2(_, _, atomic_goal(_, _, _, _, _, _), _, _, _, _, _, _) :-
+ unexpected(this_file, "annotate_goal_2: unexpected atomic_goal").
annotate_goal_2(_, _, shorthand(_), _, _, _, _, _, _) :-
unexpected(this_file, "shorthand goal").
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.28
diff -u -r1.28 transform_hlds.m
--- compiler/transform_hlds.m 3 Oct 2007 23:48:16 -0000 1.28
+++ compiler/transform_hlds.m 8 Oct 2007 23:44:01 -0000
@@ -32,6 +32,7 @@
:- include_module complexity.
:- include_module (lambda).
+:- include_module stm_expand.
:- include_module closure_analysis.
Index: compiler/tupling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tupling.m,v
retrieving revision 1.39
diff -u -r1.39 tupling.m
--- compiler/tupling.m 7 Sep 2007 15:08:19 -0000 1.39
+++ compiler/tupling.m 9 Oct 2007 03:11:59 -0000
@@ -1146,6 +1146,9 @@
"count_load_stores_in_goal: no_resume_point for if_then_else")
).
+count_load_stores_in_goal_expr(atomic_goal(_, _, _, _, _, _), _, _, !_) :-
+ unexpected(this_file,
+ "count_load_stores_in_goal_expr: unexpected atomic_goal").
count_load_stores_in_goal_expr(shorthand(_), _, _, !_) :-
unexpected(this_file,
"count_load_stores_in_goal_expr: unexpected shorthand").
@@ -1773,6 +1776,9 @@
GoalExpr = if_then_else(Vars, Cond, Then, Else),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "fix_calls_in_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "fix_calls_in_goal: unexpected shorthand")
).
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.426
diff -u -r1.426 typecheck.m
--- compiler/typecheck.m 27 Sep 2007 03:40:18 -0000 1.426
+++ compiler/typecheck.m 9 Oct 2007 04:39:47 -0000
@@ -1216,6 +1216,35 @@
GoalPath = goal_info_get_goal_path(GoalInfo),
typecheck_unification(LHS, RHS0, RHS, GoalPath, !Info),
GoalExpr = unify(LHS, RHS, UnifyMode, Unification, UnifyContext)
+ ;
+ GoalExpr0 = atomic_goal(_, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+
+ trace [io(!IO)] (
+ type_checkpoint("atomic_goal", !.Info, !IO)
+ ),
+
+ typecheck_atomic_var_pair(Outer, yes, GoalType, !Info),
+ typecheck_atomic_var_pair(Inner, no, _, !Info),
+ (
+ Vars = yes(ListOfVars),
+ ensure_vars_have_a_type(ListOfVars, !Info)
+ ;
+ Vars = no
+ ),
+
+ typecheck_goal(MainGoal0, MainGoal, !Info),
+ typecheck_goal_list(OrElseGoals0, OrElseGoals, !Info),
+
+ % XXX STM: The calls to check_goal_non_locals are commented out
+ % as the calls to "stm_outer_to_inner" and "stm_inner_to_outer" add
+ % the outer variables to the list of non-locals of the goal.
+
+% check_goal_non_locals(Outer, Inner, MainGoal, !Info),
+% list.foldr(check_goal_non_locals(Outer, Inner), OrElseGoals, !Info),
+
+ GoalExpr = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal,
+ OrElseGoals)
;
GoalExpr0 = switch(_, _, _),
unexpected(this_file, "typecheck_goal_2: unexpected switch")
@@ -1251,6 +1280,84 @@
%-----------------------------------------------------------------------------%
+:- pred typecheck_atomic_var_pair(atomic_component_state::in,
+ bool::in, atomic_goal_type::out, typecheck_info::in,
+ typecheck_info::out) is det.
+
+typecheck_atomic_var_pair(AtomicComponentState, IsOuter, GoalType, !Info) :-
+ (
+ AtomicComponentState = atomic_state_var(_ProgVar),
+ sorry(this_file, "typecheck_atomic_var_pair: state variable")
+ ;
+ AtomicComponentState = atomic_var_pair(VarDI, VarUO),
+ ensure_vars_have_a_type([VarDI, VarUO], !Info),
+ (
+ IsOuter = yes,
+ typecheck_var_has_one_of_these_types(VarDI,
+ io_state_type, stm_atomic_type, !Info),
+ typecheck_var_has_one_of_these_types(VarUO,
+ io_state_type, stm_atomic_type, !Info),
+ GoalType = unknown_atomic_goal_type
+ ;
+ IsOuter = no,
+ typecheck_var_has_type_list([VarDI, VarUO],
+ [stm_atomic_type, stm_atomic_type], 2, !Info),
+ GoalType = unknown_atomic_goal_type
+ )
+ ).
+
+
+ % Checks if the outer variables are not in the NonLocals of the goal
+ % and if the inner variables are in the NonLocals of the goal.
+ % Arguably not the best place to put this check, but the nice error
+ % reporting facilities in the typechecker are better than the ones
+ % in quantification.
+ %
+:- pred check_goal_non_locals(atomic_component_state::in,
+ atomic_component_state::in, hlds_goal::in, typecheck_info::in,
+ typecheck_info::out) is det.
+
+check_goal_non_locals(Outer, Inner, Goal, !Info) :-
+ (
+ Outer = atomic_state_var(_),
+ sorry(this_file, "check_goal_non_locals: state variable")
+ ;
+ Outer = atomic_var_pair(OuterDI, OuterUO)
+ ),
+ (
+ Inner = atomic_state_var(_),
+ sorry(this_file, "check_goal_non_locals: state variable")
+ ;
+ Inner = atomic_var_pair(InnerDI, InnerUO)
+ ),
+ OuterVarSet = set.from_list([OuterDI, OuterUO]),
+ InnerVarSet = set.from_list([InnerDI, InnerUO]),
+ Goal = hlds_goal(_, GoalInfo),
+ GoalNonLocals = goal_info_get_nonlocals(GoalInfo),
+ Context = goal_info_get_context(GoalInfo),
+ set.intersect(GoalNonLocals, OuterVarSet, OuterIntersect),
+ set.intersect(GoalNonLocals, InnerVarSet, InnerIntersect),
+ ( set.empty(OuterIntersect) ->
+ !:Info = !.Info
+ ;
+ Pieces1 = [words("Outer variables present in the atomic goal.")],
+ Msg1 = error_msg(yes(Context), no, 0, [always(Pieces1)]),
+ Spec1 = error_spec(severity_warning, phase_type_check, [Msg1]),
+ typecheck_info_add_error(Spec1, !Info)
+ ),
+ ( set.non_empty(InnerIntersect) ->
+ !:Info = !.Info
+ ;
+ Pieces2 = [words("Inner variables not present in the atomic goal."),
+ words("Is the atomic goal needed?")],
+ Msg2 = error_msg(yes(Context), no, 0, [always(Pieces2)]),
+ Spec2 = error_spec(severity_warning, phase_type_check, [Msg2]),
+ typecheck_info_add_error(Spec2, !Info)
+ ).
+
+
+%-----------------------------------------------------------------------------%
+
:- pred typecheck_goal_list(list(hlds_goal)::in, list(hlds_goal)::out,
typecheck_info::in, typecheck_info::out) is det.
@@ -1641,6 +1748,33 @@
unexpected(this_file, "arg_type_assign_var_has_type")
).
+:- pred type_assign_var_has_one_of_these_types(type_assign::in,
+ prog_var::in, mer_type::in, mer_type::in, type_assign_set::in,
+ type_assign_set::out) is det.
+
+type_assign_var_has_one_of_these_types(TypeAssign0, Var, TypeA, TypeB,
+ !TypeAssignSet) :-
+ type_assign_get_var_types(TypeAssign0, VarTypes0),
+ ( map.search(VarTypes0, Var, VarType) ->
+ ( type_assign_unify_type(TypeAssign0, VarType, TypeA, TypeAssignA) ->
+ !:TypeAssignSet = [TypeAssignA | !.TypeAssignSet]
+ ;
+ !:TypeAssignSet = !.TypeAssignSet
+ ),
+ ( type_assign_unify_type(TypeAssign0, VarType, TypeB, TypeAssignB) ->
+ !:TypeAssignSet = [TypeAssignB | !.TypeAssignSet]
+ ;
+ !:TypeAssignSet = !.TypeAssignSet
+ )
+ ;
+ % YYY
+ map.det_insert(VarTypes0, Var, TypeA, VarTypesA),
+ type_assign_set_var_types(VarTypesA, TypeAssign0, TypeAssignA),
+ map.det_insert(VarTypes0, Var, TypeB, VarTypesB),
+ type_assign_set_var_types(VarTypesB, TypeAssign0, TypeAssignB),
+ !: TypeAssignSet = [TypeAssignA, TypeAssignB | !.TypeAssignSet]
+ ).
+
%-----------------------------------------------------------------------------%
% Given a list of variables and a list of types, ensure
@@ -1684,6 +1818,36 @@
type_assign_var_has_type(TypeAssign0, Var, Type, !TypeAssignSet),
typecheck_var_has_type_2(TypeAssignSet0, Var, Type, !TypeAssignSet).
+:- pred typecheck_var_has_one_of_these_types(prog_var::in, mer_type::in,
+ mer_type::in, typecheck_info::in, typecheck_info::out) is det.
+
+typecheck_var_has_one_of_these_types(Var, TypeA, TypeB, !Info) :-
+ TypeAssignSet0 = !.Info ^ tc_info_type_assign_set,
+ typecheck_var_has_one_of_these_types_2(TypeAssignSet0, Var,
+ TypeA, TypeB, [], TypeAssignSet),
+ (
+ TypeAssignSet = [],
+ TypeAssignSet0 = [_ | _]
+ ->
+ Spec = report_error_var_either_type(!.Info, Var, TypeA, TypeB,
+ TypeAssignSet0),
+ typecheck_info_add_error(Spec, !Info)
+ ;
+ !:Info = !.Info ^ tc_info_type_assign_set := TypeAssignSet
+ ).
+
+:- pred typecheck_var_has_one_of_these_types_2(type_assign_set::in,
+ prog_var::in, mer_type::in, mer_type::in, type_assign_set::in,
+ type_assign_set::out) is det.
+
+typecheck_var_has_one_of_these_types_2([], _, _, _, !TypeAssignSet).
+typecheck_var_has_one_of_these_types_2([TypeAssign0 | TypeAssignSet0], Var, TypeA,
+ TypeB, !TypeAssignSet) :-
+ type_assign_var_has_one_of_these_types(TypeAssign0, Var, TypeA, TypeB,
+ !TypeAssignSet),
+ typecheck_var_has_one_of_these_types_2(TypeAssignSet0, Var, TypeA, TypeB,
+ !TypeAssignSet).
+
:- pred type_assign_var_has_type(type_assign::in, prog_var::in, mer_type::in,
type_assign_set::in, type_assign_set::out) is det.
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.39
diff -u -r1.39 typecheck_errors.m
--- compiler/typecheck_errors.m 17 May 2007 03:52:55 -0000 1.39
+++ compiler/typecheck_errors.m 1 Oct 2007 03:08:00 -0000
@@ -72,6 +72,9 @@
:- func report_error_var(typecheck_info, prog_var, mer_type, type_assign_set)
= error_spec.
+:- func report_error_var_either_type(typecheck_info, prog_var,
+ mer_type, mer_type, type_assign_set) = error_spec.
+
:- func report_error_arg_var(typecheck_info, prog_var, args_type_assign_set)
= error_spec.
@@ -884,6 +887,60 @@
%-----------------------------------------------------------------------------%
+report_error_var_either_type(Info, Var, TypeA, TypeB, TypeAssignSet0) = Spec :-
+ typecheck_info_get_pred_markers(Info, PredMarkers),
+ typecheck_info_get_called_predid(Info, CalledPredId),
+ ArgNum = Info ^ tc_info_arg_num,
+ Context = Info ^ tc_info_context,
+ UnifyContext = Info ^ tc_info_unify_context,
+ get_type_stuff(TypeAssignSet0, Var, TypeStuffList),
+ typecheck_info_get_varset(Info, VarSet),
+
+ InClauseForPieces = in_clause_for_pieces(Info),
+ CallContextPieces = call_context_to_pieces(PredMarkers, CalledPredId,
+ ArgNum, UnifyContext),
+
+ ActualExpectedListA0 = list.map(type_stuff_to_actual_expected(TypeA),
+ TypeStuffList),
+ ActualExpectedListB0 = list.map(type_stuff_to_actual_expected(TypeB),
+ TypeStuffList),
+ list.sort_and_remove_dups(ActualExpectedListA0, ActualExpectedListA),
+ list.sort_and_remove_dups(ActualExpectedListB0, ActualExpectedListB),
+
+ Pieces1 = [words("type error:")],
+ (
+ ActualExpectedListA = [ActualExpectedA],
+ ActualExpectedListB = [ActualExpectedB]
+ ->
+ ActualExpectedA = actual_expected_types(ActualPieces, ExpectedPiecesA),
+ ActualExpectedB = actual_expected_types(_, ExpectedPiecesB),
+ Pieces2 = argument_name_to_pieces(VarSet, Var) ++
+ [words("has type"), prefix("`")] ++ ActualPieces ++
+ [suffix("'"), suffix(","), nl,
+ words("expected type was either"), prefix("`")] ++
+ ExpectedPiecesA ++ [suffix("'"), words("or"), prefix("`")] ++
+ ExpectedPiecesB ++ [suffix("'"), suffix("."), nl]
+ ;
+ Pieces2 = [words("type of")] ++
+ argument_name_to_pieces(VarSet, Var) ++
+ [words("does not match its expected type;"), nl] ++
+ argument_name_to_pieces(VarSet, Var) ++
+ [words("has overloaded actual/expected types {"), nl] ++
+ actual_expected_types_list_to_pieces(ActualExpectedListA) ++
+ [nl, fixed("} or {."), nl] ++
+ actual_expected_types_list_to_pieces(ActualExpectedListB) ++
+ [nl, fixed("}."), nl]
+ ),
+
+ VerbosePieces = type_assign_set_msg_to_pieces(TypeAssignSet0, VarSet),
+ Msg = simple_msg(Context,
+ [always(InClauseForPieces ++ CallContextPieces),
+ always(Pieces1 ++ Pieces2),
+ verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]).
+
+%-----------------------------------------------------------------------------%
+
report_error_arg_var(Info, Var, ArgTypeAssignSet0) = Spec :-
typecheck_info_get_pred_markers(Info, PredMarkers),
typecheck_info_get_called_predid(Info, CalledPredId),
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.123
diff -u -r1.123 unique_modes.m
--- compiler/unique_modes.m 14 Aug 2007 01:52:30 -0000 1.123
+++ compiler/unique_modes.m 9 Oct 2007 03:12:37 -0000
@@ -515,6 +515,46 @@
mode_info_unset_call_context(!ModeInfo),
mode_checkpoint(exit, "foreign_proc", !ModeInfo, !IO).
+unique_modes_check_goal_expr(GoalExpr0, GoalInfo0, Goal, !ModeInfo, !IO) :-
+ GoalExpr0 = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal0,
+ OrElseGoals0),
+ mode_checkpoint(enter, "atomic_goal", !ModeInfo, !IO),
+
+ (
+ OrElseGoals0 = [],
+ unique_modes_check_goal(MainGoal0, MainGoal, !ModeInfo, !IO),
+ OrElseGoals = []
+ ;
+ OrElseGoals0 = [_ | _],
+
+ % The unique mode check on the or_else goals is very similar
+ % to the unique mode check for disjunctions. Please see
+ % "unique_modes_check_goal_expr" for disjunctions for discussion
+ % of this code.
+
+ NonLocals = goal_info_get_nonlocals(GoalInfo0),
+ Determinism = goal_info_get_determinism(GoalInfo0),
+ ( determinism_components(Determinism, _, at_most_many) ->
+ mode_info_add_live_vars(NonLocals, !ModeInfo),
+ make_all_nondet_live_vars_mostly_uniq(!ModeInfo),
+ mode_info_remove_live_vars(NonLocals, !ModeInfo)
+ ;
+ true
+ ),
+
+ List0 = [MainGoal0 | OrElseGoals0],
+
+ unique_modes_check_disj(List0, Determinism, NonLocals, List,
+ InstMapList, !ModeInfo, !IO),
+
+ MainGoal = list.det_head(List),
+ OrElseGoals = list.det_tail(List),
+
+ instmap_merge(NonLocals, InstMapList, disj, !ModeInfo)
+ ),
+ Goal = atomic_goal(GoalType, Outer, Inner, Vars, MainGoal, OrElseGoals),
+ mode_checkpoint(exit, "atomic_goal", !ModeInfo, !IO).
+
unique_modes_check_goal_expr(shorthand(_), _, _, !ModeInfo, !IO) :-
% These should have been expanded out by now.
unexpected(this_file, "unique_modes_check_goal_expr: unexpected shorthand").
Index: compiler/unneeded_code.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unneeded_code.m,v
retrieving revision 1.43
diff -u -r1.43 unneeded_code.m
--- compiler/unneeded_code.m 7 Aug 2007 07:10:09 -0000 1.43
+++ compiler/unneeded_code.m 9 Oct 2007 03:12:41 -0000
@@ -673,6 +673,9 @@
GoalExpr = scope(Reason, SomeGoal),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "process_goal_internal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "shorthand in process_goal_internal")
).
@@ -935,6 +938,9 @@
GoalExpr = scope(Reason, SomeGoal),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "refine_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "shorthand in refine_goal")
).
Index: compiler/untupling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/untupling.m,v
retrieving revision 1.28
diff -u -r1.28 untupling.m
--- compiler/untupling.m 7 Aug 2007 07:10:09 -0000 1.28
+++ compiler/untupling.m 1 Oct 2007 02:44:14 -0000
@@ -584,6 +584,9 @@
GoalExpr = if_then_else(Vars, Cond, Then, Else),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "fix_calls_in_goal: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
unexpected(this_file, "fix_calls_in_goal: unexpected shorthand")
).
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.145
diff -u -r1.145 unused_args.m
--- compiler/unused_args.m 28 Sep 2007 03:17:14 -0000 1.145
+++ compiler/unused_args.m 1 Oct 2007 02:44:14 -0000
@@ -729,6 +729,9 @@
)
)
;
+ GoalExpr = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "traverse_goal: unexpected atomic_goal")
+ ;
GoalExpr = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "traverse_goal: unexpected shorthand")
@@ -1519,6 +1522,9 @@
rename_vars_in_goal_info(need_not_rename, Subst, GoalInfo0, GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo)
;
+ GoalExpr0 = atomic_goal(_, _, _, _, _, _),
+ unexpected(this_file, "fixup_goal_expr: unexpected atomic_goal")
+ ;
GoalExpr0 = shorthand(_),
% These should have been expanded out by now.
unexpected(this_file, "fixup_goal_expr: shorthand")
Index: compiler/unused_imports.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_imports.m,v
retrieving revision 1.11
diff -u -r1.11 unused_imports.m
--- compiler/unused_imports.m 25 Sep 2007 04:56:43 -0000 1.11
+++ compiler/unused_imports.m 1 Oct 2007 02:44:14 -0000
@@ -424,6 +424,11 @@
!UsedModules) :-
hlds_goal_used_modules(GoalA, !UsedModules),
hlds_goal_used_modules(GoalB, !UsedModules).
+hlds_goal_expr_used_modules(
+ atomic_goal(_GoalType, _Outer, _Inner, _Vars, MainGoal, OrElseGoals),
+ !UsedModules) :-
+ hlds_goal_used_modules(MainGoal, !UsedModules),
+ list.foldl(hlds_goal_used_modules, OrElseGoals, !UsedModules).
:- pred unify_rhs_used_modules(unify_rhs::in,
used_modules::in, used_modules::out) is det.
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.409
diff -u -r1.409 reference_manual.texi
--- doc/reference_manual.texi 28 Sep 2007 04:57:53 -0000 1.409
+++ doc/reference_manual.texi 9 Oct 2007 01:32:54 -0000
@@ -9958,6 +9958,9 @@
@menu
* Fact tables:: Support for very large tables of facts.
+* Software Transactional Memory::
+ Support for synchronisation of threads without
+ explicit locking.
* Tabled evaluation:: Support for automatically recording previously
calculated results and detecting or avoiding
certain kinds of infinite loops.
@@ -10010,6 +10013,98 @@
not support @samp{pragma fact_table} for procedures with determinism
@samp{nondet} or @samp{multi}.
+ at node Software Transactional Memory
+ at section Software Transactional Memory
+
+(Note: Software Transactional Memory is still in development and many aspects
+documented here might change without notice. Please use with caution.)
+
+Software Transactional Memory is an alternative method of synchronising
+shared data between concurrently running threads without the use of explicit
+locking.
+
+The way to synchronise threads using Software Transactional Memory is through
+the use of the @samp{atomic} scope.
+The syntax of an atomic scope is @code{atomic @var{Params} @var{Goal}}.
+ at var{Goal} must be a valid goal;
+ at var{Params} must be a list of atomic parameters which must include the
+ at samp{outer} and @samp{inner} parameters.
+The following example shows the use of the atomic scope:
+
+ at example
+:- pred add_2_atomically(stm_var(int)::in, io::di, io::uo) is cc_multi.
+
+add_2_atomically(TVar, IO0, IO) :-
+ atomic [ outer(IO0, IO1), inner(STM0, STM) ] (
+ read_stm_var(TVar, X, STM0, STM1),
+ Y = X + 2,
+ write_stm_var(TVar, Y, STM1, STM)
+ ),
+ io.write_string("Value of Y is ", IO1, IO2),
+ io.write(Y, IO2, IO3),
+ io.nl(IO3, IO).
+ at end example
+
+The @samp{outer} parameter takes a pair of variables of the type @samp{io.io}.
+As the atomic scope can be seen as an operation which changes the I/O state,
+the modes of these variables must be @samp{di} and @samp{uo}
+respectively.
+
+The @samp{inner} parameter takes a pair of variables of the type @samp{stm}.
+When the atomic scope is executed, these variables supply and consume the
+ at samp{stm} state which can be used by the Software Transactional Memory
+primitives.
+Calling these primitives requires threading the @samp{stm} in a way similar
+to I/O operations and, as such, the modes of these variables must also
+be @samp{di} and @samp{uo}.
+
+The code within the atomic scope is restricted in the same way as code which
+takes the I/O state.
+All calls within the atomic scope must be either @samp{det} or @samp{cc_multi}.
+Due to the way Software Transactional Memory provides synchronous behaviour,
+it is likly that the goal will be executed more than once.
+As it is unknown how many times (if any) the inner goal will be repeated,
+only pure code or code which makes use of the @samp{stm} state should be
+placed inside an atomic scope.
+(Trace goals are permitted but shouldn't be used for any action that will
+depend on the number of times the goal is executed).
+
+Using the atomic scope requires the program to explicitly import the modules
+ at samp{stm_builtin}, @samp{exception} and @samp{univ}.
+This will eventually be done within the compiler itself and will be dropped
+very soon.
+
+Shared data between threads can be achieved through the use of
+ at samp{Transaction Variables}.
+This is the only form of shared data which the atomic scope will
+synchronise.
+ at samp{Transaction Variables} can be operated on using the following
+predicates:
+
+ at example
+:- pred new_stm_var(T::in, stm_var(T)::out, io::di, io::uo) is det.
+
+:- pred read_stm_var(stm_var(T)::in, T::out, stm::di, stm::uo) is det.
+
+:- pred write_stm_var(stm_var(T)::in, T::in, stm::di, stm::uo) is det.
+ at end example
+
+The @samp{new_stm_var} creates a reference to a new transaction variable
+with the type and initial value of the first argument.
+Only one copy of the transaction variable exists in memory.
+Unification and tests of the reference do not affect the transaction variables
+value directly but only the reference to the transaction variable.
+
+To get or set the value of the actual transaction variable, the calls to
+ at samp{read_stm_var} and @samp{write_stm_var} must be made.
+These calls take a reference ot a transaction variable and either set or
+return the value of the transaction variable. at footnote{In actual fact,
+changes made to the transaction variable are written to a log. Once the
+goal has completed and the log is valid, only then are the real transaction
+variables changed.}
+As the calls to @samp{read_stm_var} and @samp{write_stm_var} take an @samp{stm}
+state, they can only appear within an atomic scope.
+
@node Tabled evaluation
@section Tabled evaluation
Index: library/ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/ops.m,v
retrieving revision 1.69
diff -u -r1.69 ops.m
--- library/ops.m 30 May 2007 08:16:06 -0000 1.69
+++ library/ops.m 4 Oct 2007 06:36:11 -0000
@@ -405,6 +405,7 @@
; Op = "==>", Info = op_info(infix(x, x), 1175)
; Op = "=^", Info = op_info(infix(x, x), 650)
; Op = "@", Info = op_info(infix(x, x), 90)
+ ; Op = "or_else", Info = op_info(infix(x, y), 1100)
; Op = "end_module", Info = op_info(prefix(x), 1199)
; Op = "event", Info = op_info(prefix(x), 100)
; Op = "finalise", Info = op_info(prefix(x), 1199)
@@ -433,6 +434,7 @@
; Op = "promise_equivalent_solutions"
; Op = "promise_equivalent_solution_sets"
; Op = "trace"
+ ; Op = "atomic"
),
Info = op_info(binary_prefix(x, y), 950),
OtherInfos = []
Index: library/stm_builtin.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/stm_builtin.m,v
retrieving revision 1.12
diff -u -r1.12 stm_builtin.m
--- library/stm_builtin.m 17 Sep 2007 13:28:55 -0000 1.12
+++ library/stm_builtin.m 8 Oct 2007 23:41:39 -0000
@@ -9,10 +9,9 @@
% File: stm_builtin.m.
% Main author: lmika.
% Stability: low.
-%
-% This file is automatically imported into every module that uses software
-% transactional memory (STM). It defines the data types and predicates
-% use to implement STM.
+%
+% This module defines types and predicates that can be used with the
+% Software Transactional Memory constructs. Currently,
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -54,10 +53,14 @@
%
% Create a new transaction variable with initial value `Value'.
%
- % XXX we need a version that works within atomic blocks as well.
- %
:- pred new_stm_var(T::in, stm_var(T)::out, io::di, io::uo) is det.
+ % new_stm_var_atomic(Value, TVar, !STM):
+ %
+ % A version of new_stm_var which works within an atomic scope.
+ %
+:- pred new_stm_var_atomic(T::in, stm_var(T)::out, stm::di, stm::uo) is det.
+
% Update the value stored in a transaction variable.
%
:- pred write_stm_var(stm_var(T)::in, T::in, stm::di, stm::uo) is det.
@@ -76,20 +79,34 @@
% of at least one transaction variable read during the attempted
% transaction is written by another thread.
%
- % XXX the implementation of this predicate is incomplete. Calling it
- % will currently cause the program to abort execution.
- %
-:- pred retry(stm::di) is erroneous.
+:- pred retry(stm::ui) is erroneous.
%-----------------------------------------------------------------------------%
%
-% Atomic transactions
+% Closure versions of atomic transactions. These predicates can be used
+% to perform Software Transactional Memory without using the atomic scope.
%
+ % atomic_transaction(Closure, Result, !IO):
+ %
+ % Performs the Software Transactional Memory operations in Closure
+ % atomically. If the transaction is invalid, the Closure is
+ % re-executed.
+ %
:- pred atomic_transaction(pred(T, stm, stm), T, io, io).
:- mode atomic_transaction(in(pred(out, di, uo) is det), out, di, uo)
is det.
+
+ % or_else(AtomicClosure1, AtomicClosure2, Result, !STM):
+ %
+ % Performs the Software Transactional Memory operations in AtomicClosure1
+ % atomically. If a retry is thrown, AtomicClosure2 is executed atomically.
+ %
+:- pred or_else(pred(T, stm, stm), pred(T, stm, stm), T, stm, stm).
+:- mode or_else(in(pred(out, di, uo) is det), in(pred(out, di, uo) is det),
+ out, di, uo) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -125,6 +142,10 @@
%
:- impure pred stm_create_nested_transaction_log(stm::ui, stm::uo) is det.
+ % stm_create_nested_log(Parent, Child):
+ %
+:-impure pred stm_create_nested_log(stm::ui, stm::uo) is det.
+
% Lock the STM global mutex.
%
:- impure pred stm_lock is det.
@@ -135,9 +156,9 @@
% Values of this type are returned by stm_validate/2 and indicate
% whether a given transaction log is valid.
+ %
% NOTE: The definition of this type must be kept consistent with the
% constants defined in runtime/mercury_stm.h.
- %
%
:- type stm_validation_result
---> stm_transaction_valid
@@ -171,6 +192,21 @@
:- type stm_dummy_output
---> stm_dummy_output.
+ % Used to enforce the uniqueness of outer and inner variables.
+ % Will be removed before stm_expansion.
+ %
+:- pred stm_from_outer_to_inner_io(io::di, stm::uo) is det.
+:- pred stm_from_outer_to_inner_stm(stm::di, stm::uo) is det.
+
+:- pred stm_from_inner_to_outer_io(stm::di, io::uo) is det.
+:- pred stm_from_inner_to_outer_stm(stm::di, stm::uo) is det.
+
+ % Changes the value of a transaction variable without going through
+ % the log. ONLY USE FOR DEBUGGING PURPOSES.
+ %
+:- pred unsafe_write_stm_var(stm_var(T)::in, T::in, stm::di, stm::uo) is det.
+
+:- impure pred stm_merge_nested_logs(stm::di, stm::di, stm::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -208,6 +244,14 @@
").
:- pragma foreign_proc("C",
+ new_stm_var_atomic(T::in, TVar::out, STM0::di, STM::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ MR_STM_new_stm_var(T, TVar);
+ STM = STM0;
+").
+
+:- pragma foreign_proc("C",
write_stm_var(TVar::in, Value::in, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
@@ -216,6 +260,14 @@
").
:- pragma foreign_proc("C",
+ unsafe_write_stm_var(TVar::in, Value::in, STM0::di, STM::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ MR_STM_unsafe_write_var(TVar, Value);
+ STM = STM0;
+").
+
+:- pragma foreign_proc("C",
read_stm_var(TVar::in, Value::out, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
@@ -228,6 +280,11 @@
[will_not_call_mercury, thread_safe],
"
MR_STM_create_log(STM, NULL);
+
+ #if defined(MR_STM_DEBUG)
+ fprintf(stderr, \"STM NEW LOG: log <0x%.8lx>\\n\",
+ (MR_Word)(STM));
+ #endif
").
:- pragma foreign_proc("C",
@@ -235,6 +292,11 @@
[will_not_call_mercury, thread_safe],
"
MR_STM_create_log(Child, Parent);
+#ifdef MR_STM_DEBUG
+ fprintf(stdout, \"STM: Creating nested log <0x%.8lx>, parent <0x%.8lx>\\n\",
+ (MR_Word)(Child), (MR_Word)(Parent));
+ fflush(stdout);
+#endif
").
:- pragma foreign_proc("C",
@@ -243,21 +305,43 @@
"
MR_STM_discard_log(STM);
").
+
+:- pragma foreign_proc("C",
+ stm_create_nested_log(Parent::ui, Child::uo),
+ [will_not_call_mercury, thread_safe],
+"
+ MR_STM_create_log(Child, Parent);
+").
+
+:- pragma foreign_proc("C",
+ stm_merge_nested_logs(Child::di, Parent0::di, Parent::uo),
+ [will_not_call_mercury, thread_safe],
+"
+ /* Avoid a warning: Child, Parent0, Parent */
+ MR_STM_merge_transactions(Child);
+").
+
:- pragma foreign_proc("C",
stm_lock,
[will_not_call_mercury, thread_safe],
"
- #ifdef MR_THREAD_SAFE
+ #if defined(MR_THREAD_SAFE)
MR_LOCK(&MR_STM_lock, \"stm_lock/0\");
#endif
+ #if defined(MR_STM_DEBUG)
+ fprintf(stderr, \"STM LOCKING\\n\");
+ #endif
").
:- pragma foreign_proc("C",
stm_unlock,
[will_not_call_mercury, thread_safe],
"
- #ifdef MR_THREAD_SAFE
+ #if defined(MR_STM_DEBUG)
+ fprintf(stderr, \"STM UNLOCKING\\n\");
+ #endif
+ #if defined(MR_THREAD_SAFE)
MR_UNLOCK(&MR_STM_lock, \"stm_unlock/0\");
#endif
").
@@ -276,14 +360,47 @@
MR_STM_commit(STM);
").
+:- pragma foreign_proc("C",
+ stm_from_outer_to_inner_io(IO::di, STM::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ STM = NULL;
+ MR_final_io_state(IO);
+").
+
+:- pragma foreign_proc("C",
+ stm_from_outer_to_inner_stm(STM0::di, STM::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ STM = STM0;
+").
+
+:- pragma foreign_proc("C",
+ stm_from_inner_to_outer_io(STM0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ STM0 = NULL;
+ IO = MR_initial_io_state();
+").
+
+
+:- pragma foreign_proc("C",
+ stm_from_inner_to_outer_stm(STM0::di, STM::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ STM0 = NULL;
+ STM = NULL;
+").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
- stm_block(_STM::ui),
+ stm_block(STM::ui),
[will_not_call_mercury, thread_safe],
"
+ MR_STM_block_thread(STM);
").
+
%-----------------------------------------------------------------------------%
%
% Retry
@@ -301,6 +418,67 @@
atomic_transaction(Goal, Result, !IO) :-
impure atomic_transaction_impl(Goal, Result).
+
+:- pragma promise_pure(or_else/5).
+or_else(TransA, TransB, Result, OuterSTM0, OuterSTM) :-
+ impure stm_create_nested_log(OuterSTM0, InnerSTM_A0),
+ promise_equivalent_solutions [ResultA, InnerSTM_A] (
+ unsafe_try_stm(TransA, ResultA,
+ InnerSTM_A0, InnerSTM_A)
+ ),
+ (
+ ResultA = succeeded(Result),
+ impure stm_merge_nested_logs(InnerSTM_A, OuterSTM0, OuterSTM)
+ ;
+ ResultA = exception(ExcpA),
+ %
+ % If transaction A retried, then we should attemp transaction B.
+ % Otherwise we just propagate the exception upwards.
+ %
+ ( ExcpA = univ(rollback_retry) ->
+ impure stm_create_nested_log(OuterSTM0, InnerSTM_B0),
+ promise_equivalent_solutions [ResultB, InnerSTM_B] (
+ unsafe_try_stm(TransB, ResultB,
+ InnerSTM_B0, InnerSTM_B)
+ ),
+ (
+ ResultB = succeeded(Result),
+ impure stm_merge_nested_logs(InnerSTM_B, OuterSTM0, OuterSTM)
+ ;
+ ResultB = exception(ExcpB),
+ ( ExcpB = univ(rollback_retry) ->
+ impure stm_lock,
+ impure stm_validate(InnerSTM_A, IsValidA),
+ impure stm_validate(InnerSTM_B, IsValidB),
+ (
+ IsValidA = stm_transaction_valid,
+ IsValidB = stm_transaction_valid
+ ->
+ % We want to wait on the union of the transaction
+ % variables accessed during both alternatives. We
+ % merge the transaction logs (the order does not
+ % matter) and then propagate the retry upwards.
+ impure stm_merge_nested_logs(InnerSTM_A, OuterSTM0,
+ OuterSTM1),
+ impure stm_merge_nested_logs(InnerSTM_B, OuterSTM1,
+ OuterSTM),
+ impure stm_unlock,
+ retry(OuterSTM)
+ ;
+ impure stm_unlock,
+ throw(rollback_invalid_transaction)
+ )
+ ;
+ impure stm_unlock,
+ rethrow(ResultB)
+ )
+ )
+ ;
+ impure stm_discard_transaction_log(InnerSTM_A),
+ rethrow(ResultA)
+ )
+ ).
+
:- impure pred atomic_transaction_impl(pred(T, stm, stm), T).
:- mode atomic_transaction_impl(in(pred(out, di, uo) is det), out)
is det.
Index: mdbcomp/program_representation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/mdbcomp/program_representation.m,v
retrieving revision 1.25
diff -u -r1.25 program_representation.m
--- mdbcomp/program_representation.m 23 Sep 2007 03:53:12 -0000 1.25
+++ mdbcomp/program_representation.m 23 Sep 2007 06:16:27 -0000
@@ -302,6 +302,8 @@
; step_ite_else
; step_neg
; step_scope(maybe_cut)
+ ; step_atomic_main
+ ; step_atomic_orelse(int)
; step_first
; step_later.
@@ -580,6 +582,9 @@
path_step_from_string_2('~', "", step_neg).
path_step_from_string_2('q', "!", step_scope(scope_is_cut)).
path_step_from_string_2('q', "", step_scope(scope_is_no_cut)).
+path_step_from_string_2('a', "", step_atomic_main).
+path_step_from_string_2('o', NStr, step_atomic_orelse(N)) :-
+ string.to_int(NStr, N).
path_step_from_string_2('f', "", step_first).
path_step_from_string_2('l', "", step_later).
@@ -606,6 +611,9 @@
goal_path_step_to_string(step_neg) = "~;".
goal_path_step_to_string(step_scope(scope_is_cut)) = "q!;".
goal_path_step_to_string(step_scope(scope_is_no_cut)) = "q;".
+goal_path_step_to_string(step_atomic_main) = "a;".
+goal_path_step_to_string(step_atomic_orelse(N)) =
+ "o" ++ int_to_string(N) ++ ";".
goal_path_step_to_string(step_first) = "f;".
goal_path_step_to_string(step_later) = "l;".
Index: runtime/mercury_conf_param.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_conf_param.h,v
retrieving revision 1.99
diff -u -r1.99 mercury_conf_param.h
--- runtime/mercury_conf_param.h 13 Sep 2007 04:40:51 -0000 1.99
+++ runtime/mercury_conf_param.h 26 Sep 2007 13:12:25 -0000
@@ -306,6 +306,10 @@
** MR_STM_DEBUG
** Enabled low-level debugging messages from the code that implements
** transactions used by software transactional memory.
+**
+** MR_STM_PROFILE
+** Enabled low-level profiling and benchmarking messages from the code
+** that implements transactions used by software transactional memory.
*/
/*
Index: runtime/mercury_stm.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_stm.c,v
retrieving revision 1.5
diff -u -r1.5 mercury_stm.c
--- runtime/mercury_stm.c 21 Sep 2007 06:13:12 -0000 1.5
+++ runtime/mercury_stm.c 8 Oct 2007 05:40:23 -0000
@@ -20,8 +20,7 @@
void
MR_STM_record_transaction(MR_STM_TransLog *tlog, MR_STM_Var *var,
- MR_Word old_value, MR_Word new_value)
-{
+ MR_Word old_value, MR_Word new_value) {
MR_STM_TransRecord *new_record;
new_record = MR_GC_NEW(MR_STM_TransRecord);
@@ -33,32 +32,80 @@
}
void
-MR_STM_attach_waiter(MR_STM_Var *var, MR_ThreadId tid)
-{
- MR_fatal_error("NYI MR_STM_attach_waiter");
+MR_STM_attach_waiter(MR_STM_Var *var, MR_ThreadId tid,
+ MR_STM_ConditionVar *cvar) {
+
+ MR_STM_Waiter *new_waiter;
+
+ new_waiter = MR_GC_NEW(MR_STM_Waiter);
+ new_waiter->MR_STM_cond_var = cvar;
+
+ if (var->MR_STM_var_waiters == NULL) {
+ var->MR_STM_var_waiters = new_waiter;
+ new_waiter->MR_STM_waiter_prev = NULL;
+ new_waiter->MR_STM_waiter_next = NULL;
+ } else {
+ new_waiter->MR_STM_waiter_prev = NULL;
+ new_waiter->MR_STM_waiter_next = var->MR_STM_var_waiters;
+ var->MR_STM_var_waiters->MR_STM_waiter_prev = new_waiter;
+ var->MR_STM_var_waiters = new_waiter;
+ }
}
void
-MR_STM_detach_waiter(MR_STM_Var *var, MR_ThreadId tid)
-{
- MR_fatal_error("NYI MR_STM_detach_waiter");
+MR_STM_detach_waiter(MR_STM_Var *var, MR_STM_ConditionVar *cvar) {
+
+ MR_STM_Waiter *curr_waiter;
+
+ MR_assert(var != NULL);
+ MR_assert(var->MR_STM_var_waiters != NULL);
+
+ curr_waiter = var->MR_STM_var_waiters;
+ while (curr_waiter != NULL) {
+ if (curr_waiter->MR_STM_cond_var == cvar) {
+ if (curr_waiter == var->MR_STM_var_waiters) {
+ var->MR_STM_var_waiters =
+ var->MR_STM_var_waiters->MR_STM_waiter_next;
+ }
+ if (curr_waiter->MR_STM_waiter_prev != NULL) {
+ curr_waiter->MR_STM_waiter_prev->MR_STM_waiter_next =
+ curr_waiter->MR_STM_waiter_next;
+ }
+ if (curr_waiter->MR_STM_waiter_next != NULL) {
+ curr_waiter->MR_STM_waiter_next->MR_STM_waiter_prev =
+ curr_waiter->MR_STM_waiter_prev;
+ }
+ curr_waiter = NULL;
+ return;
+ }
+ curr_waiter = curr_waiter->MR_STM_waiter_next;
+ }
+
+ MR_fatal_error("MR_STM_detach_waiter: Thread ID not in wait queue");
}
MR_Integer
-MR_STM_validate(MR_STM_TransLog *tlog)
-{
+MR_STM_validate(MR_STM_TransLog *tlog) {
+
MR_STM_TransRecord *current;
MR_assert(tlog != NULL);
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM VALIDATE: validating log <0x%.8lx>\n", (MR_Word)tlog);
+ fprintf(stderr, "\tRecords: <0x%.8lx>\n",
+ (MR_Word)tlog->MR_STM_tl_records);
+#endif
while (tlog != NULL) {
-
current = tlog->MR_STM_tl_records;
while (current != NULL) {
if (current->MR_STM_tr_var->MR_STM_var_value !=
- current->MR_STM_tr_old_value)
- {
+ current->MR_STM_tr_old_value) {
+ #if defined(MR_STM_DEBUG)
+ fprintf(stderr, "\ttransaction INVALID.\n");
+ #endif
return MR_STM_TRANSACTION_INVALID;
}
current = current->MR_STM_tr_next;
@@ -66,26 +113,61 @@
tlog = tlog->MR_STM_tl_parent;
}
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "\ttransaction VALID.\n");
+#endif
return MR_STM_TRANSACTION_VALID;
}
void
+MR_STM_signal_vars(MR_STM_Var *tvar) {
+
+ MR_STM_Waiter *wait_queue;
+
+ wait_queue = tvar->MR_STM_var_waiters;
+
+ while (wait_queue != NULL) {
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM SIGNAL: signalling log <0x%.8lx>\n",
+ (MR_Word)wait_queue->MR_STM_cond_var);
+#endif
+ MR_STM_condvar_signal(wait_queue->MR_STM_cond_var);
+ wait_queue = wait_queue->MR_STM_waiter_next;
+ }
+}
+
+void
MR_STM_commit(MR_STM_TransLog *tlog) {
MR_STM_TransRecord *current;
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM COMMIT: committing log <0x%.8lx>\n",
+ (MR_Word)tlog);
+#endif
+
current = tlog->MR_STM_tl_records;
while (current != NULL) {
- current->MR_STM_tr_var->MR_STM_var_value
- = current->MR_STM_tr_new_value;
+ #if defined(MR_STM_DEBUG)
+ fprintf(stderr,
+ "\tSTM_Var <%.8lx>, changing value from %ld to %ld\n",
+ (MR_Word)current->MR_STM_tr_var,
+ current->MR_STM_tr_var->MR_STM_var_value,
+ current->MR_STM_tr_new_value);
+ #endif
+ current->MR_STM_tr_var->MR_STM_var_value =
+ current->MR_STM_tr_new_value;
+
+ MR_STM_signal_vars(current->MR_STM_tr_var);
current = current->MR_STM_tr_next;
}
}
void
-MR_STM_wait(MR_STM_TransLog *tlog)
-{
+MR_STM_wait(MR_STM_TransLog *tlog, MR_STM_ConditionVar *cvar) {
+
MR_STM_TransRecord *current;
MR_ThreadId this_thread_id;
@@ -93,14 +175,22 @@
current = tlog->MR_STM_tl_records;
while (current != NULL) {
- MR_STM_attach_waiter(current->MR_STM_tr_var, this_thread_id);
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM WAIT: attaching waiter on log <0x%.8lx>\n",
+ (MR_Word)tlog);
+ fprintf(stderr, "\tSTM_Var: <0x%.8lx>\n",
+ (MR_Word)current->MR_STM_tr_var);
+#endif
+
+ MR_STM_attach_waiter(current->MR_STM_tr_var, this_thread_id, cvar);
current = current->MR_STM_tr_next;
}
}
void
-MR_STM_unwait(MR_STM_TransLog *tlog)
-{
+MR_STM_unwait(MR_STM_TransLog *tlog, MR_STM_ConditionVar *cvar) {
+
MR_STM_TransRecord *current;
MR_ThreadId this_thread_id;
@@ -108,15 +198,39 @@
current = tlog->MR_STM_tl_records;
while (current != NULL) {
- MR_STM_detach_waiter(current->MR_STM_tr_var, this_thread_id);
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM UNWAIT: detaching waiter on log <0x%.8lx>\n",
+ (MR_Word)tlog);
+ fprintf(stderr, "\tSTM_Var: <0x%.8lx>\n",
+ (MR_Word)current->MR_STM_tr_var);
+#endif
+
+ MR_STM_detach_waiter(current->MR_STM_tr_var, cvar);
current = current->MR_STM_tr_next;
}
}
void
-MR_STM_write_var(MR_STM_Var *var, MR_Word value, MR_STM_TransLog *tlog)
-{
+MR_STM_unsafe_write_var(MR_STM_Var *var, MR_Word value) {
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "UNSAFE_WRITE_VAR:\n");
+ fprintf(stderr, "\tSTM_Var <%.8lx>, changing value from %ld to %ld\n",
+ (MR_Word)var,
+ var->MR_STM_var_value,
+ value);
+#endif
+
+ var->MR_STM_var_value = value;
+}
+
+
+void
+MR_STM_write_var(MR_STM_Var *var, MR_Word value, MR_STM_TransLog *tlog) {
+
MR_STM_TransRecord *current;
+ MR_STM_TransRecord *local_log;
MR_bool has_existing_record = MR_FALSE;
/*
@@ -143,8 +257,8 @@
}
MR_Word
-MR_STM_read_var(MR_STM_Var *var, MR_STM_TransLog *tlog)
-{
+MR_STM_read_var(MR_STM_Var *var, MR_STM_TransLog *tlog) {
+
MR_STM_TransLog *current_tlog;
MR_STM_TransRecord *current;
@@ -176,3 +290,87 @@
return var->MR_STM_var_value;
}
+
+void
+MR_STM_merge_transactions(MR_STM_TransLog *tlog) {
+
+ MR_STM_TransLog *parent_log;
+ MR_STM_TransRecord *parent_current;
+ MR_STM_TransRecord *current;
+ MR_STM_TransRecord *records_to_append_to_parent;
+ MR_bool found_tvar_in_parent;
+
+ MR_assert(tlog != NULL);
+ MR_assert(tlog->MR_STM_tl_parent != NULL);
+
+ parent_log = tlog->MR_STM_tl_parent;
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stdout, "STM: Merging log <0x%.8lx> with <0x%.8lx>\n", (MR_Word)tlog,
+ (MR_Word)(parent_log));
+ fflush(stdout);
+#endif
+
+ current = tlog->MR_STM_tl_records;
+ while (current != NULL) {
+
+ found_tvar_in_parent = MR_NO;
+ parent_current = parent_log->MR_STM_tl_records;
+
+ while (parent_current != NULL) {
+ if (current->MR_STM_tr_var == parent_current->MR_STM_tr_var) {
+ parent_current->MR_STM_tr_new_value =
+ current->MR_STM_tr_new_value;
+ found_tvar_in_parent = MR_YES;
+ break;
+ }
+
+ parent_current = parent_current->MR_STM_tr_next;
+ }
+
+ if (! found_tvar_in_parent) {
+ MR_STM_record_transaction(parent_log,
+ current->MR_STM_tr_var, current->MR_STM_tr_old_value,
+ current->MR_STM_tr_new_value);
+ }
+
+ current = current->MR_STM_tr_next;
+ }
+
+ /* Deallocate child log */
+#if !defined(MR_CONSERVATIVE_GC)
+ /* XXX -- Free tlog and log entries */
+#endif
+}
+
+void
+MR_STM_block_thread(MR_STM_TransLog *tlog) {
+
+#if defined(MR_THREAD_SAFE)
+ #if defined(MR_HIGHLEVEL_CODE)
+ MR_STM_ConditionVar *thread_condvar;
+
+ thread_condvar = MR_GC_NEW(MR_STM_ConditionVar);
+
+ MR_STM_wait(tlog, thread_condvar);
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM BLOCKING: log <0x%.8lx>\n", (MR_Word)tlog);
+#endif
+ MR_STM_condvar_wait(thread_condvar, &MR_STM_lock);
+ MR_UNLOCK(&MR_STM_lock, "MR_STM_block_thread");
+
+#if defined(MR_STM_DEBUG)
+ fprintf(stderr, "STM RESCHEDULING: log <0x%.8lx>\n", (MR_Word)tlog);
+#endif
+ MR_STM_unwait(tlog, thread_condvar);
+
+ MR_GC_free(thread_condvar);
+ #else
+ MR_fatal_error("Low-Level backend: Not implemented");
+ #endif
+#else
+ MR_fatal_error("Blocking thread in non-parallel grade");
+#endif
+
+}
Index: runtime/mercury_stm.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_stm.h,v
retrieving revision 1.5
diff -u -r1.5 mercury_stm.h
--- runtime/mercury_stm.h 17 Sep 2007 13:28:56 -0000 1.5
+++ runtime/mercury_stm.h 8 Oct 2007 05:51:03 -0000
@@ -9,6 +9,8 @@
/*
** mercury_stm.h - runtime support for software transactional memory.
+**
+** TODO: Currently, only the High Level C Grades have been fully implemented.
*/
#ifndef MERCURY_STM_H
@@ -17,14 +19,17 @@
#include "mercury_types.h"
#include "mercury_thread.h"
#include "mercury_conf.h"
+#include "mercury_conf_param.h"
#include "mercury_context.h"
#include "mercury_engine.h"
+#include <stdio.h>
typedef struct MR_STM_Waiter_Struct MR_STM_Waiter;
typedef struct MR_STM_Var_Struct MR_STM_Var;
typedef struct MR_STM_TransRecord_Struct MR_STM_TransRecord;
typedef struct MR_STM_TransLog_Struct MR_STM_TransLog;
+
/*
** The type MR_ThreadId provides an abstract means of identifying a Mercury
** thread. Depending upon the grade we use one of three notions of thread
@@ -44,10 +49,11 @@
#if defined(MR_HIGHLEVEL_CODE)
#if defined(MR_THREAD_SAFE)
- typedef pthread_t MR_ThreadId;
+ typedef pthread_t MR_ThreadId;
+
#define MR_THIS_THREAD_ID pthread_self()
#else
- typedef MR_Integer MR_ThreadId;
+ typedef MR_Integer MR_ThreadId;
/*
** Since these grades don't support concurrency there is only one
** thread which we always give the id 0.
@@ -57,18 +63,53 @@
#else /* !MR_HIGHLEVEL_CODE */
- typedef MR_Context *MR_ThreadId;
+ typedef MR_Context *MR_ThreadId;
#define MR_THIS_THREAD_ID (MR_ENGINE(MR_eng_this_context))
#endif /* !MR_HIGHLEVEL_CODE */
+
+/*
+** The type MR_STM_ConditionVar provides an abstract method of blocking and
+** signalling threads based on conditions.
+*/
+#if defined(MR_HIGHLEVEL_CODE)
+
+ #if defined(MR_THREAD_SAFE)
+ typedef MercuryCond MR_STM_ConditionVar;
+
+ #define MR_STM_condvar_wait(x, y) MR_cond_wait(x, y)
+ #define MR_STM_condvar_signal(x) MR_cond_signal(x)
+ #else
+ typedef MR_Integer MR_STM_ConditionVar;
+ /*
+ ** Since these grades don't support concurrency, there is no
+ ** need to block the thread.
+ */
+ #define MR_STM_condvar_wait(x, y)
+ #define MR_STM_condvar_signal(x)
+ #endif
+
+#else /* !MR_HIGHLEVEL_CODE */
+
+ typedef MR_Context *MR_STM_ConditionVar;
+
+ /*
+ ** XXX Need to implement
+ */
+ #define MR_STM_condvar_wait(x, y)
+ #define MR_STM_condvar_signal(x)
+
+#endif /* !MR_HIGHLEVEL_CODE */
+
/*
** A waiter is the identity of a thread that is blocking until the value
** of this transaction variable changes.
*/
struct MR_STM_Waiter_Struct {
- MR_ThreadId MR_STM_waiter_thread;
+ MR_STM_ConditionVar *MR_STM_cond_var;
MR_STM_Waiter *MR_STM_waiter_next;
+ MR_STM_Waiter *MR_STM_waiter_prev;
};
/*
@@ -94,6 +135,15 @@
};
/*
+** The global STM lock. This lock must be aquired before validating or
+** committing a transaction log.
+*/
+
+#if defined(MR_THREAD_SAFE)
+ extern MercuryLock MR_STM_lock;
+#endif
+
+/*
** Allocate a new transaction variable.
*/
#define MR_STM_new_stm_var(value, var) \
@@ -139,20 +189,23 @@
** listed in the log.
*/
extern void
-MR_STM_wait(MR_STM_TransLog *tlog);
+MR_STM_wait(MR_STM_TransLog *tlog, MR_STM_ConditionVar *cvar);
/*
** Detach waiters for the current thread from all of the transaction variables
** referenced by the given transaction log.
*/
extern void
-MR_STM_unwait(MR_STM_TransLog *tlog);
+MR_STM_unwait(MR_STM_TransLog *tlog, MR_STM_ConditionVar *cvar);
/*
-** Attach a waiter for thread tid to the transaction variable.
+** Attach a waiter for thread tid to the transaction variable. The condition
+** variable should be a condition variable properly initialised and associated
+** with the thread.
*/
extern void
-MR_STM_attach_waiter(MR_STM_Var *var, MR_ThreadId tid);
+MR_STM_attach_waiter(MR_STM_Var *var, MR_ThreadId tid,
+ MR_STM_ConditionVar *cvar);
/*
** Detach any waiters for thread tid from the transaction variable.
@@ -161,7 +214,7 @@
** such a waiter exists.
*/
extern void
-MR_STM_detach_waiter(MR_STM_Var *var, MR_ThreadId tid);
+MR_STM_detach_waiter(MR_STM_Var *var, MR_STM_ConditionVar *cvar);
extern MR_Integer
MR_STM_validate(MR_STM_TransLog *tlog);
@@ -172,15 +225,53 @@
extern void
MR_STM_commit(MR_STM_TransLog *tlog);
+/*
+** Changes the value of transaction variable var in a transaction log.
+*/
extern void
MR_STM_write_var(MR_STM_Var *var, MR_Word value, MR_STM_TransLog *tlog);
+/*
+** Returns the value of transaction variable var in a transaction log.
+** If no entry for var exists, the actual value of the transaction variable
+** var is returned (and added to the transaction log).
+*/
extern MR_Word
MR_STM_read_var(MR_STM_Var *var, MR_STM_TransLog *tlog);
-#if defined(MR_THREAD_SAFE)
- extern MercuryLock MR_STM_lock;
-#endif
+/*
+** Changes the value of the transaction variable var without going through
+** the log.
+**
+** NOTE: This functions must only be used for debugging purposes and will
+** eventually be removed. Please, DO NOT use it for normal operations.
+*/
+extern void
+MR_STM_unsafe_write_var(MR_STM_Var *var, MR_Word value);
+
+/*
+** Blocks a thread from execution. This method is called by the thread
+** which is to be blocked. The STM lock MUST be aquired by the
+** thread before this method is called and acquires the lock when the thread
+** is signalled.
+*/
+extern void
+MR_STM_block_thread(MR_STM_TransLog *tlog);
+
+/*
+** Merges a transaction log with its parent. Do not merge it with any
+** other ancestors. Aborts if the given transaction log does not have a
+** parent.
+*/
+extern void
+MR_STM_merge_transactions(MR_STM_TransLog *tlog);
+
+/*
+** Reschedules all threads currently waiting on the given transaction
+** variables.
+*/
+extern void
+MR_STM_signal_vars(MR_STM_Var *tvar);
/*
** These definitions need to be kept in sync with the definition of the type
Index: compiler/stm_expand.m
===================================================================
%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1995-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public Licence - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: stm.m
% Author: lm
%
% This module contains the source to source transformations for expanding out
% atomic goals.
%
% The atomic goals are converted into a series of predicate calls and
% predicate definitions using standard calls from the library modules
% "stm_builtin", "exception" and "univ".
%
% An example transformation might be the following:
%
% :- pred foo(int::in, int::out, io::di, io::uo) is det.
%
% foo(X, Y, IO0, IO) :-
% atomic [outer(IO0, IO), inner(STM0, STM)] (
% stm_operations(X, Y, STM0, STM)
% ...
% )
%
% into
%
% foo(X, Y, IO0, IO) :-
% 'StmExpanded_toplevel_0_0_0'(X, Y, IO0, IO).
%
%
% :- pred 'StmExpanded_toplevel_0_0_0'(int::in, int::out, io::di, io::uo)
% is det.
% 'StmExpanded_toplevel_0_0_0'(X, Y, IO0, IO) :-
% 'StmExpanded_rollback_0_0_0'(X, Y),
% IO0 = IO.
%
%
% :- pred 'StmExpaded_rollback_0_0_0'(int::in, int::out) is cc_multi.
% 'StmExpaded_rollback_0_0_0'(X, Y) :-
% promise_pure (
% impure stm_create_trasaction_log(STM0),
% Closure = 'StmExpanded_wrapper_0_0_0'(X),
% unsafe_try_stm(Closure(X), Result0, STM0, STM),
% (
% Result0 = succeeded(Y)
% ;
% Result0 = exception(Excp),
% ( Excp = univ(rollback_invalid_transaction) ->
% impure stm_discard_transaction_log(STM),
% 'StmExpanded_rollback_0_0_0'(X, Y)
% ; Excp = univ(rollback_retry) ->
% impure stm_lock,
% impure stm_validate(STM, IsValid),
% (
% IsValid = stm_transaction_valid,
% impure stm_block(STM)
% ;
% IsValid = stm_transaction_invalid,
% impure stm_unlock
% ),
% impure stm_discard_trasaction_log(STM),
% 'StmExpanded_rollback_0_0_0'(X, Y)
% ;
% impure stm_lock,
% impure stm_validate(STM, IsValid),
% impure stm_unlock,
% (
% IsValid = stm_transaction_valid,
% rethrow(Result0)
% ;
% IsValid = stm_transaction_invalid,
% impure stm_discard_transaction_log(STM),
% 'StmExpanded_rollback_0_0_0'(X, Y)
% )
% )
% )
% ).
%
%
% :- pred 'StmExpanded_wrapper_0_0_0'(int::in, int::out, stm::di, stm::uo)
% is det.
% 'StmExpanded_wrapper_0_0_0'(X, Result, STM0, STM) :-
% stm_operations(X, Y, STM0, STM)
% ...
% Result = Y,
% promise_pure (
% impure stm_lock,
% impure stm_validate(STM, IsValid),
% (
% IsValid = stm_transaction_valid,
% impure stm_commit(STM),
% impure stm_unlock
% ;
% IsValid = stm_transaction_invalid,
% impure stm_unlock,
% throw(rollback_invalid_transaction)
% ).
%
%
% Currently, the atomic goal supports a single STM transaction with any number
% of input and output arguments. As the atomic goal may need to unroll the
% call stack (when performing a retry or a rollback), the exception module
% is used. The use of the exception module impacts the passing of output
% variables and is explained below.
%
% Nonlocals instantiated before the atomic goal are passed through the
% expanded predicates as input arguments (with mode "in"). Nonlocals which
% are instantiated inside the atomic goal and are used outside the atomic goal
% (which, for the sake of simplicitly, will be called "output" variables in
% this discussion) are passed as output arguments in the "entrypoint" and
% "rollback" expanded predicates (with mode "out). In the "actual" expanded
% predicate, these variables must be passed as part of an exception result and
% are handled in the following way:
%
% - If there are no output variables, a dummy variable is created and
% passed up to the rollback predicate. This variable simply exists to
% satify the requirement of the closure returning an argument and
% will be ignored in the rollback predicate.
% - If there is one output variable, that variable will be passed up to
% the rollback predicate as it is.
% - If there is more than one output variable, a tupple of these variables
% is created and the tupple itself is passed up to the rollback predicate.
% There, it will be deconstructed and the associated output variables
% will be returned as output arguments.
%
% Currently a subset of the complete STM system is implemented. The following
% features will be included in subsequent review postings. A number of
% these relate to this module, whilst others relate to other modules.
%
% - or_else: Support for this exists in the front end but is not yet handled
% here (an error is thrown if or_else goals are present). There is no
% real reason for this except for the fact that it hasn't been done yet.
% This will eventually be included in the next review of this module.
%
% - Nested atomic blocks: Whilst this will eventually be incluced, this
% is neither supported in the front end or in this module (although some
% passes, such as the type checker, has code for handling this).
% However, the current method of mode checking atomic goals pervents
% nested atomic goals (the uniqueness of the outer and inner variables
% are handled by inserting dummy predicates at the beginning and end
% of the atomic goal. The current implementation of these predicates
% only allow the outer variables to be of type io).
%
% - The "vars" parameter: The "vars" atomic goal parameter is used by the
% programmer to list the outer variables. Whilst it is optional, the
% variables it lists needs to be checked to ensure that they are properly
% instantiated.
%
% - State Variables: The "outer" and "inner" atomic goal parameters are
% designed to take state variables along with variable pairs. Although
% they are handled in the parser, they are not yet handled in the
% parse tree -> HLDS transformation.
%
% - Automatic importing of necessary modules: Currently, all necessary
% modules must be explicitly imported by the programmer if they wish
% to use the STM constructs.
%
%-----------------------------------------------------------------------------%
:- module transform_hlds.stm_expand.
:- interface.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
%-----------------------------------------------------------------------------%
:- pred stm_process_module(module_info::in, module_info::out) is det.
:- pred stm_process_pred(pred_id::in, module_info::in, module_info::out)
is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module set.
:- import_module string.
:- import_module svmap.
:- import_module svvarset.
:- import_module term.
:- import_module pair.
:- import_module varset.
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module hlds.instmap.
:- import_module hlds.pred_table.
:- import_module hlds.quantification.
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_type.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
%-----------------------------------------------------------------------------%
% Information about the predicate which contains the atomic goal along
% with other information relative to all STM expansions.
%
:- type stm_info
---> stm_info(
stm_info_module_info :: module_info,
stm_info_pred_id :: pred_id,
stm_info_proc_id :: proc_id,
stm_info_proc_info :: proc_info,
stm_info_pred_info :: pred_info,
stm_info_requalify :: bool,
stm_info_expand_id :: int % Number of goals expanded
).
% Information about a newly created predicate. Mainly used to save
% explicitly passing pred_info and proc_info for creation of goals.
%
:- type stm_new_pred_info
---> stm_new_pred_info(
new_pred_module_info :: module_info,
new_pred_pred_id :: pred_id,
new_pred_proc_id :: proc_id,
new_pred_pred_info :: pred_info,
new_pred_proc_info :: proc_info,
new_pred_context :: term.context
).
% Information about the local and non-local variables of an atomic goal.
%
:- type stm_goal_vars
---> stm_goal_vars(
vars_input :: set(prog_var),
vars_local :: set(prog_var),
vars_output :: set(prog_var),
vars_innerDI :: prog_var, % inner STM di var
vars_innerUO :: prog_var % inner STM uo var
).
%-----------------------------------------------------------------------------%
stm_process_module(!ModuleInfo) :-
module_info_predids(PredIds, !ModuleInfo),
list.foldl(stm_process_pred, PredIds, !ModuleInfo),
module_info_clobber_dependency_info(!ModuleInfo).
stm_process_pred(PredId, !ModuleInfo) :-
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
ProcIds = pred_info_procids(PredInfo),
list.foldl(stm_process_proc(PredId), ProcIds, !ModuleInfo).
:- pred stm_process_proc(pred_id::in, proc_id::in, module_info::in,
module_info::out) is det.
stm_process_proc(PredId, ProcId, !ModuleInfo) :-
module_info_preds(!.ModuleInfo, PredTable0),
map.lookup(PredTable0, PredId, PredInfo0),
pred_info_get_procedures(PredInfo0, ProcTable0),
map.lookup(ProcTable0, ProcId, ProcInfo0),
stm_process_proc_2(ProcInfo0, ProcInfo, PredId, ProcId, PredInfo0,
PredInfo1, !ModuleInfo),
pred_info_get_procedures(PredInfo1, ProcTable1),
map.det_update(ProcTable1, ProcId, ProcInfo, ProcTable),
pred_info_set_procedures(ProcTable, PredInfo1, PredInfo),
module_info_preds(!.ModuleInfo, PredTable1),
map.det_update(PredTable1, PredId, PredInfo, PredTable),
module_info_set_preds(PredTable, !ModuleInfo).
:- pred stm_process_proc_2(proc_info::in, proc_info::out, pred_id::in,
proc_id::in, pred_info::in, pred_info::out, module_info::in,
module_info::out) is det.
stm_process_proc_2(!ProcInfo, PredId, ProcId, !PredInfo, !ModuleInfo) :-
proc_info_get_goal(!.ProcInfo, Goal0),
proc_info_get_initial_instmap(!.ProcInfo, !.ModuleInfo, InitInstmap),
StmInfo0 = stm_info(!.ModuleInfo, PredId, ProcId, !.ProcInfo,
!.PredInfo, no, 0),
stm_process_goal(InitInstmap, Goal0, Goal, StmInfo0, StmInfo),
StmInfo = stm_info(!:ModuleInfo, _, _, !:ProcInfo, !:PredInfo,
RecalcInfo, _),
proc_info_set_goal(Goal, !ProcInfo),
(
RecalcInfo = yes,
requantify_proc(!ProcInfo),
RecomputeAtomic = yes,
recompute_instmap_delta_proc(RecomputeAtomic, !ProcInfo, !ModuleInfo)
;
RecalcInfo = no
).
:- pred stm_process_goal(instmap::in, hlds_goal::in, hlds_goal::out,
stm_info::in, stm_info::out) is det.
stm_process_goal(Instmap, Goal0, Goal, !Info) :-
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
(
GoalExpr0 = unify(_, _, _, _, _),
Goal = Goal0
;
GoalExpr0 = conj(ConjType, Conjuncts0),
stm_process_conj(Instmap, Conjuncts0, Conjuncts, !Info),
GoalExpr = conj(ConjType, Conjuncts),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = disj(Disjuncts0),
stm_process_disj(Instmap, Disjuncts0, Disjuncts, !Info),
GoalExpr = disj(Disjuncts),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = negation(SubGoal0),
stm_process_goal(Instmap, SubGoal0, SubGoal, !Info),
GoalExpr = negation(SubGoal),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = switch(Var, CanFail, Cases0),
stm_process_switch_cases(Instmap, Cases0, Cases, !Info),
GoalExpr = switch(Var, CanFail, Cases),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = scope(Reason, InnerGoal0),
(
( Reason = exist_quant(_)
; Reason = promise_solutions(_, _)
; Reason = promise_purity(_, _)
; Reason = commit(_)
; Reason = barrier(_)
; Reason = from_ground_term(_)
; Reason = trace_goal(_, _, _, _, _)
)
),
stm_process_goal(Instmap, InnerGoal0, InnerGoal, !Info),
GoalExpr = scope(Reason, InnerGoal),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
stm_process_if_then_else(Instmap, Cond0, Then0, Else0, Cond, Then,
Else, !Info),
GoalExpr = if_then_else(Vars, Cond, Then, Else),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
( GoalExpr0 = generic_call(_, _, _, _)
; GoalExpr0 = plain_call(_, _, _, _, _, _)
; GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
),
Goal = Goal0
;
GoalExpr0 = atomic_goal(_, Outer, Inner, _, MainGoal, OrElseGoals),
(
OrElseGoals = []
;
OrElseGoals = [_ | _],
sorry(this_file, "stm_process_goal: OrElse not yet implemented")
),
InstmapDelta = goal_info_get_instmap_delta(GoalInfo0),
apply_instmap_delta(Instmap, InstmapDelta, FinalInstmap),
stm_create_actual_goal(Instmap, FinalInstmap, Outer, Inner,
MainGoal, Goal, !Info)
;
% This should be expanded out at this stage
GoalExpr0 = shorthand(_),
unexpected(this_file, "stm_process_goal: unexpected shorthand")
).
:- pred stm_process_conj(instmap::in, hlds_goals::in, hlds_goals::out,
stm_info::in, stm_info::out) is det.
stm_process_conj(Instmap0, GoalList0, GoalList, !Info) :-
(
GoalList0 = [],
GoalList = []
;
GoalList0 = [Goal0 | Goals0],
InstmapDelta = goal_info_get_instmap_delta(GoalInfo),
stm_process_goal(Instmap0, Goal0, Goal, !Info),
Goal0 = hlds_goal(_, GoalInfo),
apply_instmap_delta(Instmap0, InstmapDelta, Instmap),
stm_process_conj(Instmap, Goals0, Goals, !Info),
GoalList = [Goal | Goals]
).
:- pred stm_process_disj(instmap::in, hlds_goals::in, hlds_goals::out,
stm_info::in, stm_info::out) is det.
stm_process_disj(Instmap, GoalList0, GoalList, !Info) :-
(
GoalList0 = [],
GoalList = []
;
GoalList0 = [Goal0 | Goals0],
stm_process_goal(Instmap, Goal0, Goal, !Info),
stm_process_disj(Instmap, Goals0, Goals, !Info),
GoalList = [Goal | Goals]
).
:- pred stm_process_if_then_else(instmap::in, hlds_goal::in, hlds_goal::in,
hlds_goal::in, hlds_goal::out, hlds_goal::out, hlds_goal::out,
stm_info::in, stm_info::out) is det.
stm_process_if_then_else(Instmap0, Cond0, Then0, Else0, Cond, Then, Else,
!Info) :-
stm_process_goal(Instmap0, Cond0, Cond, !Info),
% XXX: It is currently assumed that the initial instmap of the Then part
% is the same as the final instmap of the condition part whilst the
% initial instmap of the else part is the same as the initial instmap
% of the entire if_then_else goal. I'm not sure if this is correct
% or not.
Cond0 = hlds_goal(_, CondInfo),
CondInstmapDelta = goal_info_get_instmap_delta(CondInfo),
apply_instmap_delta(Instmap0, CondInstmapDelta, InstmapAfterCond),
stm_process_goal(InstmapAfterCond, Then0, Then, !Info),
stm_process_goal(Instmap0, Else0, Else, !Info).
:- pred stm_process_switch_cases(instmap::in, list(case)::in, list(case)::out,
stm_info::in, stm_info::out) is det.
stm_process_switch_cases(Instmap0, CaseList0, CaseList, !Info) :-
(
CaseList0 = [],
CaseList = []
;
CaseList0 = [case(Functor, Goal0) | Cases0],
stm_process_goal(Instmap0, Goal0, Goal, !Info),
stm_process_switch_cases(Instmap0, Cases0, Cases, !Info),
CaseList = [case(Functor, Goal) | Cases]
).
%-----------------------------------------------------------------------------%
%
% Predicate related to the creation of the top level goal.
% Creates all the required predicates and returns the call to the
% newly created top_level goal. The InitInstmap and FinalInstmap is the
% instmap before and after the atomic goal respectivly.
%
:- pred stm_create_actual_goal(instmap::in, instmap::in,
atomic_component_state::in, atomic_component_state::in, hlds_goal::in,
hlds_goal::out, stm_info::in, stm_info::out) is det.
stm_create_actual_goal(InitInstmap, FinalInstmap, Outer, Inner, AtomicGoal,
HldsGoal, !StmInfo) :-
(
Outer = atomic_state_var(_),
sorry(this_file, "stm_create_new_goal: atomic_state_var")
;
Outer = atomic_var_pair(OuterDI, OuterUO)
),
(
Inner = atomic_state_var(_),
sorry(this_file, "stm_create_new_goal: atomic_state_var")
;
Inner = atomic_var_pair(InnerDI, InnerUO)
),
create_top_level_goal(InitInstmap, FinalInstmap, OuterDI, OuterUO,
InnerDI, InnerUO, AtomicGoal, HldsGoal, !StmInfo),
!:StmInfo = !.StmInfo ^ stm_info_requalify := yes,
increment_stm_expand_id(!StmInfo).
%-----------------------------------------------------------------------------%
%
% Predicates to determine if variables are inputs, outputs or local to a goal.
% This decision is currenly governed by the following rules:
%
% 1. If it is free in the initial instmap and not free in the final instmap,
% the variable is an output.
% 2. If it is not free in the initial instmap and not free in the final
% instmap, the
% Arranges variables into groups of local variables, input variables and
% output variables. This uses the instmap before and after the atomic
% goal.
%
:- pred order_vars_into_groups(module_info::in, list(prog_var)::in,
instmap::in, instmap::in, list(prog_var)::out, list(prog_var)::out,
list(prog_var)::out) is det.
order_vars_into_groups(ModuleInfo, Vars, InitInstmap, FinalInstmap, Local,
Input, Output) :-
order_vars_into_groups_2(ModuleInfo, Vars, InitInstmap, FinalInstmap,
[], Local, [], Input, [], Output).
:- pred order_vars_into_groups_2(module_info::in, list(prog_var)::in,
instmap::in, instmap::in, list(prog_var)::in, list(prog_var)::out,
list(prog_var)::in, list(prog_var)::out, list(prog_var)::in,
list(prog_var)::out) is det.
order_vars_into_groups_2(_, [], _, _, !Local, !Input, !Output).
order_vars_into_groups_2(ModuleInfo, [Var|Vars], InitInstmap, FinalInstmap,
!LocalVars, !InputVars, !OutputVars) :-
lookup_var(InitInstmap, Var, InitVarInst),
lookup_var(FinalInstmap, Var, FinalVarInst),
(
inst_is_free(ModuleInfo, InitVarInst),
inst_is_free(ModuleInfo, FinalVarInst)
->
!:LocalVars = [Var | !.LocalVars]
;
inst_is_free(ModuleInfo, InitVarInst),
inst_is_bound(ModuleInfo, FinalVarInst)
->
!:OutputVars = [Var | !.OutputVars]
;
inst_is_bound(ModuleInfo, InitVarInst),
inst_is_bound(ModuleInfo, FinalVarInst)
->
!:InputVars = [Var | !.InputVars]
;
unexpected(this_file,
"order_vars_into_groups_2: Unhandled inst case")
),
order_vars_into_groups_2(ModuleInfo, Vars, InitInstmap, FinalInstmap,
!LocalVars, !InputVars, !OutputVars).
:- pred calc_pred_variables_list(instmap::in, instmap::in,
hlds_goals::in, prog_var::in, prog_var::in, list(prog_var)::in,
list(stm_goal_vars)::out, stm_info::in, stm_info::out) is det.
calc_pred_variables_list(_, _, [], _, _, _, [], !StmInfo).
calc_pred_variables_list(InitInstmap, FinalInstmap, [HldsGoal | HldsGoals],
InnerDI, InnerUO, IgnoreVarList, [StmGoalVar | StmGoalVarList],
!StmInfo) :-
calc_pred_variables(InitInstmap, FinalInstmap, HldsGoal, InnerDI,
InnerUO, IgnoreVarList, StmGoalVar, !StmInfo),
calc_pred_variables_list(InitInstmap, FinalInstmap, HldsGoals, InnerDI,
InnerUO, IgnoreVarList, StmGoalVarList, !StmInfo).
% Arranges all variables from the goal and non-locals into local
% variables, input variables and output variables. All variables that
% appear in the list of IgnoreVarList are not included.
%
:- pred calc_pred_variables(instmap::in, instmap::in,
hlds_goal::in, prog_var::in, prog_var::in, list(prog_var)::in,
stm_goal_vars::out, stm_info::in, stm_info::out) is det.
calc_pred_variables(InitInstmap, FinalInstmap, HldsGoal,
InnerDI, InnerUO, IgnoreVarList, StmGoalVars, !StmInfo) :-
ModuleInfo = !.StmInfo ^ stm_info_module_info,
goal_vars(HldsGoal, GoalVars0),
HldsGoal = hlds_goal(_, GoalInfo),
set.delete_list(GoalVars0, IgnoreVarList, GoalVars),
GoalVarList = set.to_sorted_list(GoalVars),
GoalNonLocalSet0 = goal_info_get_nonlocals(GoalInfo),
set.delete_list(GoalNonLocalSet0, IgnoreVarList, GoalNonLocalSet),
GoalNonLocals = set.to_sorted_list(GoalNonLocalSet),
order_vars_into_groups(ModuleInfo, GoalVarList, InitInstmap, FinalInstmap,
LocalVarsList, _, _),
order_vars_into_groups(ModuleInfo, GoalNonLocals, InitInstmap,
FinalInstmap, _, InputVarsList, OutputVarsList),
LocalVars = set.from_list(LocalVarsList),
InputVars = set.from_list(InputVarsList),
OutputVars = set.from_list(OutputVarsList),
StmGoalVars = stm_goal_vars(InputVars, LocalVars, OutputVars, InnerDI,
InnerUO).
%-----------------------------------------------------------------------------%
%
% Predicates involved in the removal of the dummy predicates
% "stm_from_inner_to_outer_io" and "stm_from_outer_to_inner_io".
%
% Removes all calls to the dummy predicates in a list of goals.
%
:- pred remove_tail(hlds_goals::in, hlds_goals::out) is det.
remove_tail([], []).
remove_tail([G | Gs], Goals) :-
remove_tail(Gs, Goals0),
(
( G = hlds_goal(plain_call(_, _, _, _, _, stm_inner_outer), _)
; G = hlds_goal(plain_call(_, _, _, _, _, stm_outer_inner), _)
)
->
Goals = Goals0
;
Goals = [G | Goals0]
).
% Strip the dummy predicates. At the very minimum, these predicates
% should be in the atomic goal so the atomic goal must be a
% conjunction.
%
:- pred strip_goal_calls(hlds_goal::in, hlds_goal::out) is det.
strip_goal_calls(Goal0, Goal) :-
(
Goal0 = hlds_goal(conj(plain_conj, GoalList0), GoalInfo) ->
(
GoalList0 = [],
unexpected(this_file, "strip_goal_calls: conjunction is empty")
;
GoalList0 = [_ | _],
remove_tail(GoalList0, GoalList),
Goal = hlds_goal(conj(plain_conj, GoalList), GoalInfo)
)
;
unexpected(this_file, "strip_goal_calls: atomic_goal not a conj")
).
%-----------------------------------------------------------------------------%
%
% Predicates related to the creation of the top level predicate.
% The created predicate calls the rollback predicate and threads the IO state.
% Creating the top-level predicate implicitly creates the rollback predicate
% and wrapper predicates.
%
% Creates the top level predicate and returns a call to that predicate
%
:- pred create_top_level_goal(instmap::in, instmap::in, prog_var::in,
prog_var::in, prog_var::in, prog_var::in, hlds_goal::in, hlds_goal::out,
stm_info::in, stm_info::out) is det.
create_top_level_goal(InitInstmap, FinalInstmap, OuterDI, OuterUO,
InnerDI, InnerUO, AtomicGoal0, HldsGoal, !StmInfo) :-
strip_goal_calls(AtomicGoal0, AtomicGoal_TMP),
calc_pred_variables(InitInstmap, FinalInstmap, AtomicGoal0,
InnerDI, InnerUO, [OuterDI, OuterUO, InnerDI, InnerUO], AtomicGoalVars,
!StmInfo),
create_top_level_pred(AtomicGoalVars, OuterDI, OuterUO, AtomicGoal_TMP,
TopLevelCall, !StmInfo),
HldsGoal = TopLevelCall.
% Creates the top level predicate. Calling this implicitly creates the
% rollback and wrapper predicate.
%
:- pred create_top_level_pred(stm_goal_vars::in, prog_var::in, prog_var::in,
hlds_goal::in, hlds_goal::out, stm_info::in, stm_info::out) is det.
create_top_level_pred(AtomicGoalVars, OuterDI, OuterUO, AtomicGoal, HldsGoal,
!StmInfo) :-
create_rollback_pred(AtomicGoalVars, WrapperCall, AtomicGoal, !StmInfo),
get_input_output_varlist(AtomicGoalVars, InputVars, OutputVars),
get_input_output_types(AtomicGoalVars, !.StmInfo, InputTypes, OutputTypes),
get_input_output_modes(AtomicGoalVars, InputModes, OutputModes),
create_cloned_pred(InputVars ++ OutputVars ++ [OuterDI, OuterUO],
InputTypes ++ OutputTypes ++ [stm_io_type, stm_io_type],
InputModes ++ OutputModes ++ [mer_mode_di, mer_mode_uo], "toplevel",
AtomicGoal, NewPredInfo0, HldsGoal, !StmInfo),
create_var_unify(OuterUO, OuterDI, pair(mer_mode_uo, mer_mode_di),
CopyIOAssign, NewPredInfo0, NewPredInfo1),
create_plain_conj([WrapperCall, CopyIOAssign], TopLevelGoal),
new_pred_set_goal(TopLevelGoal, NewPredInfo1, NewPredInfo2),
run_quantification_over_pred(NewPredInfo2, NewPredInfo),
commit_new_pred(NewPredInfo, !StmInfo).
%-----------------------------------------------------------------------------%
%
% Template predicates. These predicates are used to create frequently
% occurring patterns in the predicate clause.
%
% Predicate that creates the following goal:
%
% (
% X <- univ.univ(<<ExceptRes>>),
% X == << stm_rollback_exception_functor >>
% ->
% << true_goal >>
% ;
% << false_goal >>
% )
%
% The RttiVar variable must contain ...
%
:- pred template_if_exceptres_is_cons(prog_var::in, prog_var::in, cons_id::in,
hlds_goal::in, hlds_goal::in, hlds_goal::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
template_if_exceptres_is_cons(RttiVar, ExceptVar, RollbackExceptCons,
TrueGoal, FalseGoal, HldsGoal, !NewPredInfo) :-
create_aux_variable(stm_valid_result_type, yes("UnivPayload"),
UnivPayloadVar, !NewPredInfo),
create_aux_variable_assignment(RollbackExceptCons,
stm_rollback_exception_type, yes("RollbackExcpt"), AssignGoal,
RollbackExceptVar, !NewPredInfo),
create_simple_call(module_univ_sym_name, "type_to_univ", pf_predicate,
mode_no(2), detism_semi, purity_pure,
[RttiVar, UnivPayloadVar, ExceptVar], [],
[pair(RttiVar, ground(shared, none)),
pair(ExceptVar, ground(shared, none)), pair(UnivPayloadVar, free)],
UnivCall, !NewPredInfo),
create_simple_call(module_builtin_sym_name, "unify", pf_predicate,
only_mode, detism_semi, purity_pure,
[RttiVar, RollbackExceptVar, UnivPayloadVar], [],
[], UnifyCall, !NewPredInfo),
create_var_test(UnivPayloadVar, RollbackExceptVar,
pair(mer_mode_in, mer_mode_in), TestGoal, !NewPredInfo),
create_plain_conj([AssignGoal, UnivCall, TestGoal, UnifyCall], CondGoal),
ITEDetermism = detism_det,
ITEPurity = purity_impure,
create_if_then_else([], CondGoal, TrueGoal, FalseGoal, ITEDetermism,
ITEPurity, HldsGoal, !NewPredInfo).
% Predicate that creates the following goals.
%
% impure stm_builtin.lock,
% impure stm_builtin.validate(<<STM>>, IsValid),
% { impure stm_builtin.unlock } when unlock_after == yes
% (
% IsValid = stm_transaction_valid,
% << TrueGoal >>
% ;
% IsValid = stm_transaction_invalid,
% << FalseGoal >>
% )
%
% The call to "stm_builtin.unlock" is only included if the value of
% UnlockAfterwards is yes.
%
:- pred template_lock_and_validate(prog_var::in, bool::in, hlds_goal::in,
hlds_goal::in, hlds_goals::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
template_lock_and_validate(StmVar, UnlockAfterwards, ValidGoal, InvalidGoal,
HldsGoals, !NewPredInfo) :-
create_aux_variable(stm_valid_result_type, yes("ValidResult"),
IsValidVar, !NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_lock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], LockCall,
!NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_validate", pf_predicate,
only_mode, detism_det, purity_impure, [StmVar, IsValidVar], [],
[pair(StmVar, ground(unique, none)), pair(IsValidVar, free)],
ValidCall, !NewPredInfo),
create_switch_disjunction(IsValidVar,
[case(stm_validres_valid_functor, ValidGoal),
case(stm_validres_invalid_functor, InvalidGoal)], detism_det,
purity_impure, DisjGoal, !NewPredInfo),
(
UnlockAfterwards = yes,
create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], UnlockCall,
!NewPredInfo),
HldsGoals = [LockCall, ValidCall, UnlockCall, DisjGoal]
;
UnlockAfterwards = no,
HldsGoals = [LockCall, ValidCall, DisjGoal]
).
%-----------------------------------------------------------------------------%
%
% Predicates involved in the creation of the rollback predicate. The rollback
% predicate is responsible for calling the wrapper predicate and handling
% the excepion result. If the exception result indicates a rollback because
% of an invalid transaction or a retry, this predicate is responsible for
% handling these. For an example of the goals created by this predicate,
% please see the comment in the top of this file.
%
% Creates the necessary goals for handling exceptions that do not indicate
% a rollback. The role of the these goals is to validate the transaction
% log and act upon the result. The goals created are listed below:
%
% impure stm_builtin.stm_lock,
% impure stm_builtin.validate(STM, IsValid),
% impure stm_builtin.stm_unlock,
% (
% IsValid = stm_transaction_valid,
% rethrow(Exception)
% ;
% IsValid = stm_transaction_invalid,
% impure stm_discard_transaction_log(STM),
% 'StmExpanded_rollback_0_0_0'(X, Y)
% )
%
:- pred create_validate_exception_goal(prog_var::in, prog_var::in,
mer_type::in, hlds_goal::in, hlds_goal::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_validate_exception_goal(StmVar, ExceptionVar, ReturnType, RecursiveCall,
HldsGoal, !NewPredInfo) :-
make_type_info(ReturnType, TypeInfoVar, CreateTypeInfoGoals, !NewPredInfo),
create_simple_call(module_exception_sym_name, "rethrow", pf_predicate,
only_mode, detism_det, purity_pure, [TypeInfoVar, ExceptionVar], [],
[pair(TypeInfoVar, ground(shared, none)),
pair(ExceptionVar, ground(shared, none))],
HldsGoal_ExceptionThrow_Call, !NewPredInfo),
create_plain_conj(CreateTypeInfoGoals ++ [HldsGoal_ExceptionThrow_Call],
HldsGoal_ValidBranch),
create_plain_conj([RecursiveCall], HldsGoal_InvalidBranch),
template_lock_and_validate(StmVar, yes, HldsGoal_ValidBranch,
HldsGoal_InvalidBranch, HldsGoals, !NewPredInfo),
create_plain_conj(HldsGoals, HldsGoal).
% Creates the necessary goals for handling explicit retries. The role
% of these goals is to validate the log and block the thread if the
% log is valid (provided that transaction variables to wait on exist
% in the log).
%
:- pred create_retry_handler_branch(prog_var::in, hlds_goal::in,
hlds_goal::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_retry_handler_branch(StmVar, RecCall, HldsGoal, !NewPredInfo) :-
create_simple_call(module_stm_sym_name, "stm_block", pf_predicate,
only_mode, detism_det, purity_impure, [StmVar], [],
[pair(StmVar, ground(unique, none))], BlockGoal, !NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], UnlockGoal,
!NewPredInfo),
template_lock_and_validate(StmVar, no, BlockGoal, UnlockGoal,
LockAndValidateGoals, !NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_discard_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure,
[StmVar], [], [pair(StmVar, ground(clobbered, none))],
DropStateCall, !NewPredInfo),
create_plain_conj(LockAndValidateGoals ++ [DropStateCall, RecCall],
HldsGoal).
% Creates the necessary goals for switching on an exception. The role of
% the created goals is to extract the exception from the exception result
% (using predicates from the "univ" module) and create the if-then-else
% statements which branch on the result.
%
:- pred create_test_on_exception(prog_var::in, prog_var::in, mer_type::in,
hlds_goal::in, hlds_goal::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_test_on_exception(ExceptVar, StmVar, ReturnType, RecCall, HldsGoal,
!NewPredInfo) :-
create_aux_variable(stm_univ_type, yes("ExceptUnivVar"), ExceptUnivVar,
!NewPredInfo),
deconstruct_functor(ExceptVar, stm_exceptres_exception_functor,
[ExceptUnivVar], DeconstructException),
make_type_info(stm_rollback_exception_type, TypeInfoRollbackVar,
TypeInfoRollbackAssign, !NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_discard_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure, [StmVar], [],
[pair(StmVar, ground(clobbered, none))], DropStateGoal, !NewPredInfo),
create_plain_conj([DropStateGoal, RecCall], TrueGoal),
create_validate_exception_goal(StmVar, ExceptVar, ReturnType, RecCall,
RethrowBranch, !NewPredInfo),
create_retry_handler_branch(StmVar, RecCall, RetryBranch, !NewPredInfo),
template_if_exceptres_is_cons(TypeInfoRollbackVar, ExceptUnivVar,
stm_rollback_retry_functor, RetryBranch, RethrowBranch, FalseGoal,
!NewPredInfo),
template_if_exceptres_is_cons(TypeInfoRollbackVar, ExceptUnivVar,
stm_rollback_exception_functor, TrueGoal, FalseGoal, IfThenElseGoal,
!NewPredInfo),
create_plain_conj([DeconstructException] ++ TypeInfoRollbackAssign ++
[IfThenElseGoal], HldsGoal).
% Creates the main goal for the rollback predicate. The goals created
% by this predicate create the closure for the wrapper predicate and
% deconstructs the value returned if no exception is present. It
% relies on the above predicates to generate code for handling exceptions.
%
:- pred create_rollback_handler_goal(stm_goal_vars::in, mer_type::in,
prog_var::in, prog_var::in, pred_proc_id::in, hlds_goal::in,
hlds_goal::out, stm_info::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_rollback_handler_goal(AtomicGoalVars, ReturnType, StmVarDI, StmVarUO,
WrapperID, RecCall, HldsGoal, StmInfo, !NewPredInfo) :-
% Creates the higher order type for the wrapper closure.
WrapperIDShroud = shroud_pred_proc_id(WrapperID),
get_input_output_varlist(AtomicGoalVars, InputVars, _),
get_input_output_types(AtomicGoalVars, StmInfo, InputTypes, _),
get_input_output_modes(AtomicGoalVars, InputModes, _),
construct_higher_order_pred_type(purity_pure, lambda_normal,
InputTypes ++ [ReturnType, stm_state_type, stm_state_type],
Wrapper_HO_Type),
Wrapper_HO_Functor = pred_const(WrapperIDShroud, lambda_normal),
create_aux_variable(Wrapper_HO_Type, yes("AtomicClosure"),
AtomicClosureVar, !NewPredInfo),
make_type_info(ReturnType, RttiTypeVar, RttiTypeVarAssign, !NewPredInfo),
construct_functor(AtomicClosureVar, Wrapper_HO_Functor, InputVars,
ClosureAssign0),
ClosureAssignInstmapDeltaList = assoc_list.from_corresponding_lists(
[AtomicClosureVar],
[ground(shared, higher_order(pred_inst_info(pf_predicate,
InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
detism_det)))]),
instmap_delta_from_assoc_list(ClosureAssignInstmapDeltaList,
ClosureAssignInstmapDelta),
ClosureAssign0 = hlds_goal(ClosureAssignExpr, ClosureAssignInfo0),
goal_info_set_instmap_delta(ClosureAssignInstmapDelta, ClosureAssignInfo0,
ClosureAssignInfo),
ClosureAssign = hlds_goal(ClosureAssignExpr, ClosureAssignInfo),
% Creates the necessary exception types, based on the output type of
% the stm predicate.
Exception_Result_Type = stm_exception_result_type(ReturnType),
ExceptRes_Success_Functor = stm_exceptres_success_functor,
ExceptRes_Failure_Functor = stm_exceptres_exception_functor,
create_aux_variable(Exception_Result_Type, yes("ExceptionResult"),
ReturnExceptVar, !NewPredInfo),
create_simple_call(module_stm_sym_name, "stm_create_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure, [StmVarDI], [],
[pair(StmVarDI, ground(unique, none))], HldsGoal_StmCreate,
!NewPredInfo),
% TODO: Select mode based on determism of actual goal. 0 if determistic,
% 1 if cc_multi.
create_simple_call(module_exception_sym_name, "unsafe_try_stm",
pf_predicate, mode_no(0), detism_cc_multi, purity_pure,
[RttiTypeVar, AtomicClosureVar, ReturnExceptVar, StmVarDI, StmVarUO],
[], [pair(RttiTypeVar, ground(shared, none)),
pair(AtomicClosureVar, ground(shared, none)),
pair(ReturnExceptVar, ground(shared, none)),
pair(StmVarDI, ground(clobbered, none)),
pair(StmVarUO, ground(unique, none))], HldsGoal_TryStm,
!NewPredInfo),
% For successfull execution, deconstruct and return true
deconstruct_output(AtomicGoalVars, ReturnType, ReturnExceptVar,
Branch_AtomicSuccess, StmInfo, !NewPredInfo),
create_test_on_exception(ReturnExceptVar, StmVarUO, ReturnType, RecCall,
Branch_AtomicException, !NewPredInfo),
create_switch_disjunction(ReturnExceptVar,
[case(ExceptRes_Failure_Functor, Branch_AtomicException),
case(ExceptRes_Success_Functor, Branch_AtomicSuccess)],
detism_det, purity_impure, DisjGoal, !NewPredInfo),
create_plain_conj([HldsGoal_StmCreate] ++ RttiTypeVarAssign ++
[ClosureAssign, HldsGoal_TryStm, DisjGoal], HldsGoal0),
create_promise_purity_scope(HldsGoal0, purity_pure, HldsGoal).
% Creates the rollback predicate. This predicate is responsible for
% making the closure to the wrapper predicate and executing it whilst
% catching any possible exceptions that might be thrown It is also
% responsible for handing retries and rollbacks.
%
:- pred create_rollback_pred(stm_goal_vars::in, hlds_goal::out, hlds_goal::in,
stm_info::in, stm_info::out) is det.
create_rollback_pred(AtomicGoalVars, CallGoal, AtomicGoal,
!StmInfo) :-
get_input_output_varlist(AtomicGoalVars, InputVars, OutputVars),
get_input_output_types(AtomicGoalVars, !.StmInfo, InputTypes, OutputTypes),
get_input_output_modes(AtomicGoalVars, InputModes, OutputModes),
create_cloned_pred(InputVars ++ OutputVars, InputTypes ++ OutputTypes,
InputModes ++ OutputModes, "rollback", AtomicGoal, NewPredInfo0,
CallGoal, !StmInfo),
create_rollback_pred_2(AtomicGoalVars, CallGoal, AtomicGoal,
NewPredInfo0, NewPredInfo, !StmInfo),
commit_new_pred(NewPredInfo, !StmInfo).
:- pred create_rollback_pred_2(stm_goal_vars::in, hlds_goal::in, hlds_goal::in,
stm_new_pred_info::in, stm_new_pred_info::out, stm_info::in,
stm_info::out) is det.
create_rollback_pred_2(AtomicGoalVars, RecCallGoal, AtomicGoal, !NewPredInfo,
!StmInfo) :-
get_input_output_types(AtomicGoalVars, !.StmInfo, _, OutputTypes),
make_return_type(OutputTypes, ResultType),
create_aux_variable(ResultType, yes("ResltVar"), ResultVar, !NewPredInfo),
create_aux_variable(stm_state_type, yes("STM0"), InnerDI, !NewPredInfo),
create_aux_variable(stm_state_type, yes("STM"), InnerUO, !NewPredInfo),
% Temporally commits the predicate to the StmInfo so that the wrapper
% predicate can have the most up to date copy of the module info.
commit_new_pred(!.NewPredInfo, !StmInfo),
create_wrapper_pred(AtomicGoalVars, ResultType, ResultVar, AtomicGoal,
WrapperID, _, !StmInfo),
% Stores the up to date module info back into the new predicate info.
update_new_pred_info(!.StmInfo, !NewPredInfo),
create_rollback_handler_goal(AtomicGoalVars, ResultType, InnerDI, InnerUO,
WrapperID, RecCallGoal, RollbackGoal, !.StmInfo, !NewPredInfo),
new_pred_set_goal(RollbackGoal, !NewPredInfo),
run_quantification_over_pred(!NewPredInfo),
commit_new_pred(!.NewPredInfo, !StmInfo).
%-----------------------------------------------------------------------------%
%
% Predicates involved in moving local variables from the original predicate
% to the newly created wrapper predicate.
% Moves a single variable, along with its type, from the original
% predicate to the newly created wrapper predicate.
%
:- pred apply_varset_to_preds(prog_var::in, prog_varset::in, prog_varset::out,
vartypes::in, vartypes::out, prog_varset::in, prog_varset::out,
vartypes::in, vartypes::out, prog_var_renaming::in,
prog_var_renaming::out) is det.
apply_varset_to_preds(ProgVar, !NewPredVarSet, !NewPredVarTypes,
!OldPredVarSet, !OldPredVarTypes, !VarMapping) :-
map.lookup(!.OldPredVarTypes, ProgVar, ProgType),
delete_var(!.OldPredVarSet, ProgVar, !:OldPredVarSet),
map.delete(!.OldPredVarTypes, ProgVar, !:OldPredVarTypes),
new_var(NewProgVar, !NewPredVarSet),
map.det_insert(!.NewPredVarTypes, NewProgVar, ProgType,
!:NewPredVarTypes),
map.det_insert(!.VarMapping, ProgVar, NewProgVar, !:VarMapping).
% Moves all local variables from the original predicate to the newly
% created wrapper predicate. This also includes the original STM
% di and uo variables.
%
:- pred move_variables_to_new_pred(hlds_goal::in, hlds_goal::out,
stm_goal_vars::in, prog_var::in, prog_var::in, stm_new_pred_info::in,
stm_new_pred_info::out, stm_info::in, stm_info::out) is det.
move_variables_to_new_pred(AtomicGoal0, AtomicGoal, AtomicGoalVars,
InnerDI, InnerUO, !NewPredInfo, !StmInfo) :-
NewProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
OldProcInfo0 = !.StmInfo ^ stm_info_proc_info,
proc_info_get_varset(NewProcInfo0, NewPredVarSet0),
proc_info_get_vartypes(NewProcInfo0, NewPredVarTypes0),
proc_info_get_varset(OldProcInfo0, OldPredVarSet0),
proc_info_get_vartypes(OldProcInfo0, OldPredVarTypes0),
AtomicGoalVars = stm_goal_vars(_, LocalVars, _, OrigInnerDI, OrigInnerUO),
LocalVarList = set.to_sorted_list(LocalVars),
VarMapping0 = map.init,
list.foldl5(apply_varset_to_preds, LocalVarList,
NewPredVarSet0, NewPredVarSet, NewPredVarTypes0, NewPredVarTypes,
OldPredVarSet0, OldPredVarSet, OldPredVarTypes0, OldPredVarTypes,
VarMapping0, VarMapping1),
( OrigInnerDI = OrigInnerUO ->
map.det_insert(VarMapping1, OrigInnerDI, InnerDI, VarMapping)
;
map.det_insert(VarMapping1, OrigInnerDI, InnerDI, VarMapping2),
map.det_insert(VarMapping2, OrigInnerUO, InnerUO, VarMapping)
),
rename_some_vars_in_goal(VarMapping, AtomicGoal0, AtomicGoal),
proc_info_set_varset(NewPredVarSet, NewProcInfo0, NewProcInfo1),
proc_info_set_vartypes(NewPredVarTypes, NewProcInfo1, NewProcInfo),
proc_info_set_varset(OldPredVarSet, OldProcInfo0, OldProcInfo1),
proc_info_set_vartypes(OldPredVarTypes, OldProcInfo1, OldProcInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := NewProcInfo,
!:StmInfo = !.StmInfo ^ stm_info_proc_info := OldProcInfo.
%-----------------------------------------------------------------------------%
%
% Predicates involved in the creation of the wrapper predicate.
%
% Creates the wrapper predicate. Return the pred_proc_id of the newly
% created wrapper predicate as well as a goal to call it.
%
:- pred create_wrapper_pred(stm_goal_vars::in, mer_type::in, prog_var::in,
hlds_goal::in, pred_proc_id::out, hlds_goal::out, stm_info::in,
stm_info::out) is det.
create_wrapper_pred(AtomicGoalVars, ResultType, ResultVar0, AtomicGoal,
PredProcId, CallGoal, !StmInfo) :-
create_wrapper_pred_2(AtomicGoalVars, ResultType, ResultVar0, AtomicGoal,
PredProcId, _, CallGoal, !StmInfo).
:- pred create_wrapper_pred_2(stm_goal_vars::in, mer_type::in, prog_var::in,
hlds_goal::in, pred_proc_id::out, stm_new_pred_info::out, hlds_goal::out,
stm_info::in, stm_info::out) is det.
create_wrapper_pred_2(AtomicGoalVars, ResultType, ResultVar0,
!.AtomicGoal, PredProcId, !:NewPredInfo, CallGoal, !StmInfo) :-
InnerDI = AtomicGoalVars ^ vars_innerDI,
InnerUO0 = AtomicGoalVars ^ vars_innerUO,
get_input_output_varlist(AtomicGoalVars, InputVars, _),
get_input_output_types(AtomicGoalVars, !.StmInfo, InputTypes, _),
get_input_output_modes(AtomicGoalVars, InputModes, _),
create_cloned_pred(InputVars ++ [ResultVar0, InnerDI, InnerUO0],
InputTypes ++ [ResultType, stm_state_type, stm_state_type],
InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
"wrapper", !.AtomicGoal, !:NewPredInfo, CallGoal, !StmInfo),
rename_var_in_wrapper_pred("stm_ResultVar", ResultVar0, ResultType,
ResultVar, !NewPredInfo, !AtomicGoal),
move_variables_to_new_pred(!AtomicGoal, AtomicGoalVars, InnerDI, InnerUO0,
!NewPredInfo, !StmInfo),
% Handles the case when the Inner di and Inner uo variables are the same.
% Explicitly creates a unification to keep these variables different
% (because of the uniqueness requirements of a number of calls added to
% the end of the original goal)
( InnerUO0 = InnerDI ->
CopyStm = yes,
create_aux_variable(stm_state_type, yes("NewUO"), InnerUO,
!NewPredInfo),
set_head_vars(InputVars ++ [ResultVar0, InnerDI, InnerUO], !NewPredInfo)
;
CopyStm = no,
InnerUO = InnerUO0
),
create_post_wrapper_goal(AtomicGoalVars, !.AtomicGoal, ResultType,
ResultVar, InnerDI, InnerUO, CopyStm, WrapperGoal, !.StmInfo,
!NewPredInfo),
new_pred_set_goal(WrapperGoal, !NewPredInfo),
run_quantification_over_pred(!NewPredInfo),
get_pred_proc_id(!.NewPredInfo, PredProcId),
commit_new_pred(!.NewPredInfo, !StmInfo).
% Creates the goals for validating and committing (or raising a rollback
% exception) a transaction log. These goals appear after the original
% goal. If the value of CopySTM is "yes", a goal unifying the variable
% in StmDI and the variable in StmUO will be created before the log
% is validated.
%
:- pred create_post_wrapper_goal(stm_goal_vars::in, hlds_goal::in,
mer_type::in, prog_var::in, prog_var::in, prog_var::in, bool::in,
hlds_goal::out, stm_info::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_post_wrapper_goal(AtomicGoalVars, AtomicGoal, ResultType, ResultVar,
StmDI, StmUO, CopySTM, HldsGoal, StmInfo, !NewPredInfo) :-
StmModuleName = module_stm_sym_name,
ExceptionModuleName = module_exception_sym_name,
construct_output(AtomicGoalVars, ResultType, ResultVar, StmInfo,
AssignResult, !NewPredInfo),
create_aux_variable(stm_valid_result_type, yes("Stm_Expand_IsValid"),
IsValidVar, !NewPredInfo),
ValidTrueFunctor = stm_validres_valid_functor,
ValidFalseFunctor = stm_validres_invalid_functor,
RollbackCons = stm_rollback_exception_functor,
% Creates the necessary predicate calls.
create_aux_variable_assignment(RollbackCons, stm_rollback_exception_type,
yes("Stm_Expand_Rollback"), ConstRollbackGoal, RollbackVar,
!NewPredInfo),
create_simple_call(StmModuleName, "stm_lock", pf_predicate, only_mode,
detism_det, purity_impure, [], [], [], HldsGoal_StmLock_Call,
!NewPredInfo),
create_simple_call(StmModuleName, "stm_unlock", pf_predicate, only_mode,
detism_det, purity_impure, [], [], [], HldsGoal_StmUnLock_Call,
!NewPredInfo),
create_simple_call(StmModuleName, "stm_validate", pf_predicate, only_mode,
detism_det, purity_impure, [StmUO, IsValidVar], [],
[pair(StmUO, ground(unique, none)),
pair(IsValidVar, ground(shared, none))], HldsGoal_StmValidate_Call,
!NewPredInfo),
create_simple_call(StmModuleName, "stm_commit", pf_predicate, only_mode,
detism_det, purity_impure, [StmUO], [],
[pair(StmUO, ground(unique, none))], HldsGoal_StmCommit_Call,
!NewPredInfo),
make_type_info(stm_rollback_exception_type, TypeInfoVar,
CreateTypeInfoGoals, !NewPredInfo),
create_simple_call(ExceptionModuleName, "throw", pf_predicate, only_mode,
detism_det, purity_pure, [TypeInfoVar, RollbackVar], [],
[pair(TypeInfoVar, ground(shared, none)),
pair(RollbackVar, ground(shared, none))],
HldsGoal_ExceptionThrow_Call, !NewPredInfo),
% Creates the branch on the validation result of the log.
create_plain_conj([HldsGoal_StmCommit_Call, HldsGoal_StmUnLock_Call],
HldsGoal_ValidBranch),
create_plain_conj([HldsGoal_StmUnLock_Call, ConstRollbackGoal] ++
CreateTypeInfoGoals ++ [HldsGoal_ExceptionThrow_Call],
HldsGoal_InvalidBranch),
create_switch_disjunction(IsValidVar,
[case(ValidTrueFunctor, HldsGoal_ValidBranch),
case(ValidFalseFunctor, HldsGoal_InvalidBranch)],
detism_det, purity_impure, DisjGoal, !NewPredInfo),
% Creates the main validation and commission goal.
PostAtomicTopLevelList = [HldsGoal_StmLock_Call,
HldsGoal_StmValidate_Call, DisjGoal],
create_plain_conj(PostAtomicTopLevelList, PostAtomicGoal0),
create_promise_purity_scope(PostAtomicGoal0, purity_pure, PostAtomicGoal),
% Creates the unification between StmUO and StmDI is needed.
( CopySTM = yes ->
create_var_unify(StmUO, StmDI, pair(mer_mode_uo, mer_mode_di),
CopySTMAssign, !NewPredInfo),
TopLevelGoalList0 = [AtomicGoal] ++ AssignResult ++ [CopySTMAssign,
PostAtomicGoal]
;
TopLevelGoalList0 = [AtomicGoal] ++ AssignResult ++
[PostAtomicGoal]
),
flatten_conj(TopLevelGoalList0, TopLevelGoalList),
create_plain_conj(TopLevelGoalList, HldsGoal).
%-----------------------------------------------------------------------------%
%
% Utility predicates used in the creation of the rollback predicate and the
% wrapper predicate.
%
% Returns the type of the value that is to be returned by the wrapper
% predicate given the types of the output variables.
%
:- pred make_return_type(list(mer_type)::in, mer_type::out) is det.
make_return_type(Types, ReturnType) :-
(
Types = [],
ReturnType = stm_dummy_output_type
;
Types = [_ | _],
( Types = [SingleType] ->
ReturnType = SingleType
;
ReturnType = tuple_type(Types, kind_star)
)
).
% Creates the goals necessary for extracting the output variables from
% the return value of the wrapper.
%
:- pred deconstruct_output(stm_goal_vars::in, mer_type::in, prog_var::in,
hlds_goal::out, stm_info::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
deconstruct_output(AtomicGoalVars, ReturnType, ReturnExceptVar,
HldsGoal, StmInfo, !NewPredInfo) :-
get_input_output_varlist(AtomicGoalVars, _, OutputVars),
get_input_output_types(AtomicGoalVars, StmInfo, _, OutputTypes),
( OutputTypes = [] ->
% Extract the return type but do nothing with it. For reasons that
% I do not know, this is the bare minimum that is required without
% causing an exception in a later stage.
create_aux_variable(ReturnType, yes("BoringResult"), SucessResultVar,
!NewPredInfo),
deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
[SucessResultVar], HldsGoal)
; OutputTypes = [_] ->
% Wrapper returns a single value -- Simply get the value from the
% exception result and return.
OutVar = list.det_head(OutputVars),
deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
[OutVar], HldsGoal)
;
% Wrapper returns a tupple. Get the tupple result and return it.
make_type_info(ReturnType, _, MakeType, !NewPredInfo),
create_aux_variable(ReturnType, yes("SucessResult"), SucessResultVar,
!NewPredInfo),
deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
[SucessResultVar], DeconstructGoal),
deconstruct_tuple(SucessResultVar, OutputVars, UnifyOutputGoal),
create_plain_conj([DeconstructGoal, UnifyOutputGoal | MakeType],
HldsGoal)
).
% Creates the goals necessary for constructing the output variables
% in the wrapper predicate. It is necessary to compress all the output
% values into a single variable to be passed along with the exception
% result.
%
:- pred construct_output(stm_goal_vars::in, mer_type::in, prog_var::in,
stm_info::in, hlds_goals::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
construct_output(AtomicGoalVars, ResultType, ResultVar, StmInfo, HldsGoals,
!NewPredInfo) :-
get_input_output_varlist(AtomicGoalVars, _, OutputVars),
get_input_output_types(AtomicGoalVars, StmInfo, _, OutputTypes),
( OutputTypes = [] ->
% Since a value must be returned, simply return a value which will be
% discarded.
create_const_assign(ResultVar, stm_dummy_output_functor, HldsGoal),
HldsGoals = [HldsGoal]
; OutputTypes = [_] ->
% Wrapper returns a single value -- Simply get the value from the
% exception result and return.
OutVar = list.det_head(OutputVars),
create_var_unify(ResultVar, OutVar, pair(mer_mode_out, mer_mode_in),
HldsGoal, !NewPredInfo),
HldsGoals = [HldsGoal]
;
% Wrapper returns a tupple. Creates a tupple from the output values.
make_type_info(ResultType, _, MakeType, !NewPredInfo),
hlds_goal.construct_tuple(ResultVar, OutputVars, HldsGoal),
HldsGoals = [HldsGoal | MakeType]
).
% Renames the value of a variable in a predicate.
%
:- pred rename_var_in_wrapper_pred(string::in, prog_var::in, mer_type::in,
prog_var::out, stm_new_pred_info::in, stm_new_pred_info::out,
hlds_goal::in, hlds_goal::out) is det.
rename_var_in_wrapper_pred(Name, ResultVar0, ResultType, ResultVar,
!NewPredInfo, !HldsGoal) :-
NewProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
proc_info_get_varset(NewProcInfo0, NewPredVarSet0),
proc_info_get_vartypes(NewProcInfo0, NewPredVarTypes0),
proc_info_get_headvars(NewProcInfo0, NewHeadVars0),
delete_var(NewPredVarSet0, ResultVar0, NewPredVarSet1),
map.delete(NewPredVarTypes0, ResultVar0, NewPredVarTypes1),
new_named_var(Name, ResultVar, NewPredVarSet1, NewPredVarSet),
map.det_insert(NewPredVarTypes1, ResultVar, ResultType, NewPredVarTypes),
VarMapping0 = map.init,
map.det_insert(VarMapping0, ResultVar0, ResultVar, VarMapping),
MapLambda = ((pred(X::in, Y::out) is det) :-
( X = ResultVar0 ->
Y = ResultVar
;
Y = X
)
),
list.map(MapLambda, NewHeadVars0, NewHeadVars),
rename_some_vars_in_goal(VarMapping, !HldsGoal),
proc_info_set_varset(NewPredVarSet, NewProcInfo0, NewProcInfo1),
proc_info_set_vartypes(NewPredVarTypes, NewProcInfo1, NewProcInfo2),
proc_info_set_headvars(NewHeadVars, NewProcInfo2, NewProcInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := NewProcInfo.
%-----------------------------------------------------------------------------%
%
% Predicates to assist in the creation of hlds_goals. To simplify the creation
% of goals in a predicate, many of these functions thread the type
% "stm_new_pred_info" which contains, amonst other things, the predicate info,
% procedure info and module info of the newly created predicate.
%
% Many of the created goals create default instmap_deltas and non-local
% variable sets. This is because it is assumed that quantification and
% recalculation of the instmap_deltas will be done over the newly created
% predicate (the call to "run_quantification_over_pred" will do this).
%
% Creates an auxiliary variable with a specific type
%
:- pred create_aux_variable(mer_type::in, maybe(string)::in, prog_var::out,
stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_aux_variable(Type, MaybeName, Var, !NewPredInfo) :-
ProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
proc_info_create_var_from_type(Type, MaybeName, Var, ProcInfo0, ProcInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := ProcInfo.
% Creates a goal which assigns a variable to a cons_id.
%
:- pred create_const_assign(prog_var::in, cons_id::in, hlds_goal::out) is det.
create_const_assign(Var, Const, AssignmentGoal) :-
make_const_construction(Var, Const, AssignmentGoal).
% Creates a new auxiliary variable and a goal which assigns it to a
% cons_id.
%
:- pred create_aux_variable_assignment(cons_id::in, mer_type::in,
maybe(string)::in, hlds_goal::out, prog_var::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_aux_variable_assignment(Cons, Type, MaybeName, Goal, Var,
!NewPredInfo) :-
create_aux_variable(Type, MaybeName, Var, !NewPredInfo),
create_const_assign(Var, Cons, Goal).
% Creates a simple test between two variables (using the unify goal).
%
:- pred create_var_test(prog_var::in, prog_var::in, unify_mode::in,
hlds_goal::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_var_test(VarLHS, VarRHS, UnifyMode, HldsGoal, !NewPredInfo) :-
Context = !.NewPredInfo ^ new_pred_context,
ModuleInfo = !.NewPredInfo ^ new_pred_module_info,
UnifyType = simple_test(VarLHS, VarRHS),
UnifyRHS = rhs_var(VarRHS),
UnifyContext = unify_context(umc_explicit, []),
UnifyMode = ModeLHS - ModeRHS,
instmap_delta_from_mode_list([VarLHS, VarRHS], [ModeLHS, ModeRHS],
ModuleInfo, InstmapDelta),
HldsGoalExpr = unify(VarLHS, UnifyRHS, UnifyMode, UnifyType, UnifyContext),
set.init(NonLocals0),
set.insert(NonLocals0, VarLHS, NonLocals1),
set.insert(NonLocals1, VarRHS, NonLocals),
Determism = detism_semi,
Purity = purity_pure,
goal_info_init(NonLocals, InstmapDelta, Determism, Purity, Context,
HldsGoalInfo),
HldsGoal = hlds_goal(HldsGoalExpr, HldsGoalInfo).
% Creates a unification between two variables (using the unify goal)
%
:- pred create_var_unify(prog_var::in, prog_var::in, unify_mode::in,
hlds_goal::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_var_unify(VarLHS, VarRHS, UnifyMode, HldsGoal, !NewPredInfo) :-
Context = !.NewPredInfo ^ new_pred_context,
ModuleInfo = !.NewPredInfo ^ new_pred_module_info,
UnifyType = assign(VarLHS, VarRHS),
UnifyRHS = rhs_var(VarRHS),
UnifyContext = unify_context(umc_explicit, []),
UnifyMode = ModeLHS - ModeRHS,
instmap_delta_from_mode_list([VarLHS, VarRHS], [ModeLHS, ModeRHS],
ModuleInfo, InstmapDelta),
HldsGoalExpr = unify(VarLHS, UnifyRHS, UnifyMode, UnifyType, UnifyContext),
set.init(NonLocals0),
set.insert(NonLocals0, VarLHS, NonLocals1),
set.insert(NonLocals1, VarRHS, NonLocals),
Determism = detism_det,
Purity = purity_pure,
goal_info_init(NonLocals, InstmapDelta, Determism, Purity, Context,
HldsGoalInfo),
HldsGoal = hlds_goal(HldsGoalExpr, HldsGoalInfo).
% Creates a simple call. If the call is polymorphic, remember to add
% the runtime type information as well ("type_info" variable).
%
:- pred create_simple_call(module_name::in, string::in, pred_or_func::in,
mode_no::in, determinism::in, purity::in, prog_vars::in,
list(goal_feature)::in, assoc_list(prog_var, mer_inst)::in,
hlds_goal::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_simple_call(ModuleName, ProcName, PredOrFunc, Mode, Detism, Purity,
ProgVars, GoalFeatures, InstmapDelta, Goal, !NewPredInfo) :-
Context = !.NewPredInfo ^ new_pred_context,
ModuleInfo = !.NewPredInfo ^ new_pred_module_info,
generate_simple_call(ModuleName, ProcName, PredOrFunc, Mode, Detism,
Purity, ProgVars, GoalFeatures, InstmapDelta, ModuleInfo, Context,
Goal).
% Creates an if-then-else goal.
%
:- pred create_if_then_else(list(prog_var)::in, hlds_goal::in, hlds_goal::in,
hlds_goal::in, determinism::in, purity::in, hlds_goal::out,
stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_if_then_else(ExistVars, Cond, Then, Else, Detism, Purity, OutGoal,
!NewPredInfo) :-
Context = !.NewPredInfo ^ new_pred_context,
OutGoalExpr = if_then_else(ExistVars, Cond, Then, Else),
NonLocals = set.init,
instmap_delta_init_reachable(InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, Detism, Purity, Context,
GoalInfo),
OutGoal = hlds_goal(OutGoalExpr, GoalInfo).
% Creates a switch goal.
%
:- pred create_switch_disjunction(prog_var::in, list(case)::in,
determinism::in, purity::in, hlds_goal::out, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
create_switch_disjunction(ProgVar, Cases, Detism, Purity, OutGoal,
!NewPredInfo) :-
Context = !.NewPredInfo ^ new_pred_context,
NonLocals = set.init,
instmap_delta_init_reachable(InstMapDelta),
OutGoalExpr = switch(ProgVar, cannot_fail, Cases),
goal_info_init(NonLocals, InstMapDelta, Detism, Purity, Context,
GoalInfo),
OutGoal = hlds_goal(OutGoalExpr, GoalInfo).
% Creates a promise_purity around a goal for a given purity.
%
:- pred create_promise_purity_scope(hlds_goal::in, purity::in,
hlds_goal::out) is det.
create_promise_purity_scope(HldsGoalIn, ScopePurity, HldsGoalOut) :-
HldsGoalIn = hlds_goal(_, GoalInInfo),
NonLocals = goal_info_get_nonlocals(GoalInInfo),
InstMapDelta = goal_info_get_instmap_delta(GoalInInfo),
Detism = goal_info_get_determinism(GoalInInfo),
GoalPurity = ScopePurity,
Context = goal_info_get_context(GoalInInfo),
goal_info_init(NonLocals, InstMapDelta, Detism, GoalPurity, Context,
GoalInfo),
Reason = promise_purity(dont_make_implicit_promises, ScopePurity),
HldsGoalOutExpr = scope(Reason, HldsGoalIn),
HldsGoalOut = hlds_goal(HldsGoalOutExpr, GoalInfo).
% Creates a list of regular conjoined goals.
%
:- pred create_plain_conj(hlds_goals::in, hlds_goal::out) is det.
create_plain_conj(GoalsInConj, ConjGoal) :-
Type = plain_conj,
ConjGoalExpr = conj(Type, GoalsInConj),
goal_list_nonlocals(GoalsInConj, NonLocals),
goal_list_instmap_delta(GoalsInConj, InstMapDelta),
goal_list_determinism(GoalsInConj, Detism),
goal_list_purity(GoalsInConj, Purity),
GoalAInfo = list.det_head(GoalsInConj) ^ hlds_goal_info,
Context = goal_info_get_context(GoalAInfo),
goal_info_init(NonLocals, InstMapDelta, Detism, Purity, Context,
ConjGoalInfo),
ConjGoal = hlds_goal(ConjGoalExpr, ConjGoalInfo).
% Create typeinfo for use in polymorphic predicates
%
:- pred make_type_info(mer_type::in, prog_var::out,
hlds_goals::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
make_type_info(Type, Var, HldsGoals, NewPredInfo0, NewPredInfo) :-
NewPredInfo0 = stm_new_pred_info(ModuleInfo0, PredId, ProcId,
PredInfo0, ProcInfo0, Context),
create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0),
polymorphism_make_type_info_var(Type, Context, Var, HldsGoals,
PolyInfo0, PolyInfo),
poly_info_extract(PolyInfo, PredInfo0, PredInfo, ProcInfo0, ProcInfo,
ModuleInfo),
NewPredInfo = stm_new_pred_info(ModuleInfo, PredId, ProcId,
PredInfo, ProcInfo, Context).
% Returns the list of goals from a case
%
:- pred goals_from_case_list(list(case)::in, hlds_goals::out) is det.
goals_from_case_list(CaseList, GoalList) :-
StripCase = (pred(Case::in, Goal::out) is det :- Case = case(_, Goal)),
list.map(StripCase, CaseList, GoalList).
%-----------------------------------------------------------------------------%
%
% Predicates to assist in the creation of new predicates.
%
% Creates a new predicate. The head variables, head variable types, head
% variable modes, name and goal of the new predicate are set from the
% arguments. All other properties are copied from the predicate in which
% the original atomic goal appears in. The predicate returns a
% "stm_new_pred_info" value (so that the body of the predicate can be
% built) as well as a call to the new predicate.
%
:- pred create_cloned_pred(list(prog_var)::in, list(mer_type)::in,
list(mer_mode)::in, string::in, hlds_goal::in, stm_new_pred_info::out,
hlds_goal::out, stm_info::in, stm_info::out) is det.
create_cloned_pred(ProcHeadVars, PredArgTypes, ProcHeadModes,
Prefix, OrigGoal, NewStmPredInfo, CallGoal, !StmInfo) :-
ModuleInfo0 = !.StmInfo ^ stm_info_module_info,
PredInfo = !.StmInfo ^ stm_info_pred_info,
ProcId = !.StmInfo ^ stm_info_proc_id,
PredId = !.StmInfo ^ stm_info_pred_id,
ExpansionCnt = !.StmInfo ^ stm_info_expand_id,
list.length(ProcHeadVars, Arity),
OrigGoal = hlds_goal(_, GoalInfo0),
pred_info_proc_info(PredInfo, ProcId, ProcInfo),
proc_info_get_context(ProcInfo, ProcContext),
proc_info_get_varset(ProcInfo, ProcVarSet),
proc_info_get_vartypes(ProcInfo, ProcVarTypes),
proc_info_get_inst_varset(ProcInfo, ProcInstVarSet),
proc_info_get_inferred_determinism(ProcInfo, ProcDetism),
proc_info_get_goal(ProcInfo, ProcGoal),
proc_info_get_rtti_varmaps(ProcInfo, ProcRttiVarMaps),
proc_info_get_var_name_remap(ProcInfo, VarNameRemap),
proc_info_create(ProcContext, ProcVarSet, ProcVarTypes, ProcHeadVars,
ProcInstVarSet, ProcHeadModes, ProcDetism, ProcGoal, ProcRttiVarMaps,
address_is_not_taken, VarNameRemap, NewProcInfo),
ModuleName = pred_info_module(PredInfo),
OrigPredName = pred_info_name(PredInfo),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
pred_info_get_context(PredInfo, PredContext),
NewPredName = qualified(ModuleName, "StmExpanded_" ++ Prefix ++ "_" ++
OrigPredName ++ "_" ++ string(Arity) ++ "_" ++ string(PredId) ++
"_" ++ string(ExpansionCnt)),
pred_info_get_origin(PredInfo, OrigPredOrigin),
NewPredOrigin = origin_transformed(transform_stm_expansion,
OrigPredOrigin, PredId),
pred_info_get_typevarset(PredInfo, PredTypeVarSet),
pred_info_get_exist_quant_tvars(PredInfo, PredExistQVars),
pred_info_get_class_context(PredInfo, PredClassContext),
pred_info_get_assertions(PredInfo, PredAssertions),
pred_info_get_markers(PredInfo, Markers),
pred_info_create(ModuleName, NewPredName, PredOrFunc, PredContext,
NewPredOrigin, status_local, Markers, PredArgTypes,
PredTypeVarSet, PredExistQVars, PredClassContext, PredAssertions,
VarNameRemap, NewProcInfo, NewProcId, NewPredInfo),
module_info_get_predicate_table(ModuleInfo0, PredicateTable0),
predicate_table_insert(NewPredInfo, NewPredId,
PredicateTable0, PredicateTable),
module_info_set_predicate_table(PredicateTable, ModuleInfo0,
ModuleInfo),
CallExpr = plain_call(NewPredId, NewProcId, ProcHeadVars, not_builtin, no,
NewPredName),
set.init(CallNonLocals0),
set.insert_list(CallNonLocals0, ProcHeadVars, CallNonLocals),
instmap_delta_from_mode_list(ProcHeadVars, ProcHeadModes, ModuleInfo0,
CallInstmapDelta),
CallDeterminism = goal_info_get_determinism(GoalInfo0),
CallPurity = goal_info_get_purity(GoalInfo0),
CallContext = goal_info_get_context(GoalInfo0),
goal_info_init(CallNonLocals, CallInstmapDelta, CallDeterminism,
CallPurity, CallContext, GoalInfo),
CallGoal = hlds_goal(CallExpr, GoalInfo),
!:StmInfo = !.StmInfo ^ stm_info_module_info := ModuleInfo,
NewStmPredInfo = stm_new_pred_info(ModuleInfo, NewPredId, NewProcId,
NewPredInfo, NewProcInfo, CallContext).
% Sets the head variables of the new predicate.
%
:- pred set_head_vars(list(prog_var)::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
set_head_vars(NewHeadVars, !NewPredInfo) :-
ProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
proc_info_set_headvars(NewHeadVars, ProcInfo0, ProcInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := ProcInfo.
% Writes the changes made to the new predicate to the predicate table
% and returns an updates the stm_info state.
%
:- pred commit_new_pred(stm_new_pred_info::in, stm_info::in,
stm_info::out) is det.
commit_new_pred(NewPred, StmInfo0, StmInfo) :-
StmInfo0 = stm_info(_StmModuleInfo0, OrigPredId, OrigProcId, OrigProcInfo,
OrigPredInfo, StmExpanded, ExpandNum),
NewPred = stm_new_pred_info(PredModuleInfo0, NewPredId, NewProcId,
NewPredInfo, NewProcInfo, _),
module_info_set_pred_proc_info(NewPredId, NewProcId, NewPredInfo,
NewProcInfo, PredModuleInfo0, PredModuleInfo),
StmInfo = stm_info(PredModuleInfo, OrigPredId, OrigProcId, OrigProcInfo,
OrigPredInfo, StmExpanded, ExpandNum).
% If changes have been made to the stm_info type (specifically the
% module_info), update these changes in stm_new_pred_info.
%
:- pred update_new_pred_info(stm_info::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
update_new_pred_info(StmInfo, !NewPredInfo) :-
ModuleInfo = StmInfo ^ stm_info_module_info,
!:NewPredInfo = !.NewPredInfo ^ new_pred_module_info := ModuleInfo.
% Runs quantification and recalculates the instmap-delta over the
% new predicate.
%
:- pred run_quantification_over_pred(stm_new_pred_info::in,
stm_new_pred_info::out) is det.
run_quantification_over_pred(!NewPredInfo) :-
ProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
ModuleInfo0 = !.NewPredInfo ^ new_pred_module_info,
requantify_proc(ProcInfo0, ProcInfo1),
RecomputeAtomic = yes,
recompute_instmap_delta_proc(RecomputeAtomic, ProcInfo1, ProcInfo,
ModuleInfo0, ModuleInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_module_info := ModuleInfo,
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := ProcInfo.
% Sets the goal of the new predicate.
%
:- pred new_pred_set_goal(hlds_goal::in, stm_new_pred_info::in,
stm_new_pred_info::out) is det.
new_pred_set_goal(HldsGoal, !NewPredInfo) :-
ProcInfo0 = !.NewPredInfo ^ new_pred_proc_info,
goal_vars(HldsGoal, GoalVars0),
proc_info_get_varset(ProcInfo0, ProcVarSet0),
proc_info_get_vartypes(ProcInfo0, ProcVarTypes0),
varset.select(ProcVarSet0, GoalVars0, ProgVarSet),
map.select(ProcVarTypes0, GoalVars0, ProcVarTypes),
proc_info_set_varset(ProgVarSet, ProcInfo0, ProcInfo1),
proc_info_set_goal(HldsGoal, ProcInfo1, ProcInfo2),
proc_info_set_vartypes(ProcVarTypes, ProcInfo2, ProcInfo),
!:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := ProcInfo.
% Returns the pred_proc_id of the new predicate.
%
:- pred get_pred_proc_id(stm_new_pred_info::in, pred_proc_id::out) is det.
get_pred_proc_id(NewPredInfo0, PredProcId) :-
PredId = NewPredInfo0 ^ new_pred_pred_id,
ProcId = NewPredInfo0 ^ new_pred_proc_id,
PredProcId = proc(PredId, ProcId).
%-----------------------------------------------------------------------------%
%
% Miscellaneous predicates.
%
% Increments the stm expand id
%
:- pred increment_stm_expand_id(stm_info::in, stm_info::out) is det.
increment_stm_expand_id(!StmInfo) :-
ExpandId0 = !.StmInfo ^ stm_info_expand_id,
ExpandId = ExpandId0 + 1,
!:StmInfo = !.StmInfo ^ stm_info_expand_id := ExpandId.
%-----------------------------------------------------------------------------%
%
% Predicates related to the goal variables.
%
% Get the list of input and output variables of the original atomic goal.
%
:- pred get_input_output_varlist(stm_goal_vars::in, list(prog_var)::out,
list(prog_var)::out) is det.
get_input_output_varlist(StmGoalVars, Input, Output) :-
InputSet = StmGoalVars ^ vars_input,
OutputSet = StmGoalVars ^ vars_output,
Input = set.to_sorted_list(InputSet),
Output = set.to_sorted_list(OutputSet).
% Get the list of types corresponding to the input and output
% variables of the original atomic goal.
%
:- pred get_input_output_types(stm_goal_vars::in, stm_info::in,
list(mer_type)::out, list(mer_type)::out) is det.
get_input_output_types(StmGoalVars, StmInfo, InputTypes, OutputTypes) :-
ProcInfo0 = StmInfo ^ stm_info_proc_info,
proc_info_get_vartypes(ProcInfo0, VarTypes),
get_input_output_varlist(StmGoalVars, InputVars, OutputVars),
list.map(map.lookup(VarTypes), InputVars, InputTypes),
list.map(map.lookup(VarTypes), OutputVars, OutputTypes).
% Used by "get_input_output_modes".
%
:- pred set_list_val(X::in, Y::in, X::out) is det.
set_list_val(X, _, X).
% Get the list of modes corresponding to the input and output
% variables of the original atomic goal. Input variables will have
% the mode "in" while output variables will have the mode "out".
%
:- pred get_input_output_modes(stm_goal_vars::in, list(mer_mode)::out,
list(mer_mode)::out) is det.
get_input_output_modes(StmGoalVars, InputModes, OutputModes) :-
get_input_output_varlist(StmGoalVars, InputVars, OutputVars),
list.map(set_list_val(mer_mode_in), InputVars, InputModes),
list.map(set_list_val(mer_mode_out), OutputVars, OutputModes).
%-----------------------------------------------------------------------------%
%
% Constants of modules, types and functors that are useful in this source to
% source transformation.
%
% Module names
%
:- func module_stm_sym_name = sym_name.
:- func module_exception_sym_name = sym_name.
:- func module_univ_sym_name = sym_name.
:- func module_builtin_sym_name = sym_name.
:- func module_io_sym_name = sym_name.
% Special (dummy) predicate names
%
:- func stm_inner_outer = sym_name.
:- func stm_outer_inner = sym_name.
% Types
%
:- func stm_state_type = mer_type.
:- func stm_valid_result_type = mer_type.
:- func stm_rollback_exception_type = mer_type.
:- func stm_dummy_output_type = mer_type.
:- func stm_univ_type = mer_type.
:- func stm_io_type = mer_type.
:- func stm_exception_result_type(mer_type) = mer_type.
% Function symbols (ie: cons_id)
%
:- func stm_validres_valid_functor = cons_id.
:- func stm_validres_invalid_functor = cons_id.
:- func stm_rollback_exception_functor = cons_id.
:- func stm_rollback_retry_functor = cons_id.
:- func stm_dummy_output_functor = cons_id.
:- func stm_exceptres_success_functor = cons_id.
:- func stm_exceptres_exception_functor = cons_id.
% Modes
%
:- func mer_mode_in = mer_mode.
:- func mer_mode_out = mer_mode.
:- func mer_mode_di = mer_mode.
:- func mer_mode_uo = mer_mode.
module_stm_sym_name = mercury_stm_builtin_module.
module_builtin_sym_name = mercury_public_builtin_module.
module_exception_sym_name = unqualified("exception").
module_univ_sym_name = unqualified("univ").
module_io_sym_name = unqualified("io").
stm_inner_outer = qualified(module_stm_sym_name, "stm_from_inner_to_outer_io").
stm_outer_inner = qualified(module_stm_sym_name, "stm_from_outer_to_inner_io").
stm_state_type =
defined_type(qualified(module_stm_sym_name, "stm"), [], kind_star).
stm_valid_result_type =
defined_type(qualified(module_stm_sym_name, "stm_validation_result"),
[], kind_star).
stm_rollback_exception_type =
defined_type(qualified(module_stm_sym_name, "rollback_exception"), [],
kind_star).
stm_dummy_output_type =
defined_type(qualified(module_stm_sym_name, "stm_dummy_output"), [],
kind_star).
stm_univ_type =
defined_type(qualified(module_univ_sym_name, "univ"), [], kind_star).
stm_io_type =
defined_type(qualified(module_io_sym_name, "state"), [], kind_star).
stm_exception_result_type(SubType) =
defined_type(qualified(module_exception_sym_name, "exception_result"),
[SubType], kind_star).
stm_validres_valid_functor =
cons(qualified(module_stm_sym_name, "stm_transaction_valid"), 0).
stm_validres_invalid_functor =
cons(qualified(module_stm_sym_name, "stm_transaction_invalid"), 0).
stm_rollback_exception_functor =
cons(qualified(module_stm_sym_name, "rollback_invalid_transaction"), 0).
stm_rollback_retry_functor =
cons(qualified(module_stm_sym_name, "rollback_retry"), 0).
stm_dummy_output_functor =
cons(qualified(module_stm_sym_name, "stm_dummy_output"), 0).
stm_exceptres_success_functor =
cons(qualified(module_exception_sym_name, "succeeded"), 1).
stm_exceptres_exception_functor =
cons(qualified(module_exception_sym_name, "exception"), 1).
mer_mode_in = user_defined_mode(qualified(unqualified("builtin"), "in"), []).
mer_mode_out = user_defined_mode(qualified(unqualified("builtin"), "out"), []).
mer_mode_di = user_defined_mode(qualified(unqualified("builtin"), "di"), []).
mer_mode_uo = user_defined_mode(qualified(unqualified("builtin"), "uo"), []).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "stm_expand.m".
%-----------------------------------------------------------------------------%
:- end_module transform_hlds.stm_expand.
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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