[m-dev.] for discussion: higher-order `any' insts
Mark Brown
mark at csse.unimelb.edu.au
Wed Jan 9 00:32:20 AEDT 2008
Hi all,
Programming with solver types and higher-order code in Mercury is a bit
painful at the moment, because we have no way of safely handling pred and
func expressions that may bind non-local solver variables. The current
solution is to make such higher-order values impure (which, unfortunately,
tends to then spread everywhere).
The code below implements an alternative approach. This is designed to
allow us to use solver types and higher-order code without resorting to
impurity.
Feedback is welcome (and happy new year, everyone :-))
Cheers,
Mark.
Estimated hours taken: 100
Branches: main
Implement higher-order `any' insts. Pred or func expressions with an `any'
inst may bind non-local solver variables, but themselves must not be
called in a negated context. (The existing ground pred and func expressions
may not bind non-local solver variables, but may be called in a negated
context.
Higher-order `any' insts are specified by using `any_pred' and `any_func'
in place of `pred' and `func', respectively.
We implement these insts by adding a new field to the any/1 constructor of
mer_inst, which is identical to the ground_inst_info field of the ground/2
constructor. Both are given the new type `ho_inst_info'. We then relax the
locking of non-local variables in these pred and func expressions, and extend
call/N and apply/N to also accept the new insts (provided the variables are
not locked).
We also store the groundness (ho_ground or ho_any) of each lambda expression
in a unification, in a new field in the rhs_lambda_goal constructor.
compiler/prog_data.m:
Rename the ground_inst_info type ho_inst_info, and update its
documentation.
Add the ho_inst_info field to the any constructor in mer_inst.
compiler/hlds_goal.m:
Add the rhs_groundness field to rhs_lambda_goal in unify_rhs.
compiler/inst_match.m:
Propagate inst matching into the pred_inst_infos of any insts,
if they exist.
compiler/inst_util.m:
Propagate abstract unification and inst merging into the
pred_inst_infos of any insts, if they exist. May use of this
information when building ground, any, shared and mostly_unique
versions of insts.
compiler/modecheck_call.m:
Allow an `any' inst as the pred (func) argument to call/N (apply/N),
but check that the variable is not locked. If the variable is
locked, report a mode error which suggests using the ground inst.
(We could also suggest that the goal be made impure, but it is
best to point users towards the pure approach.)
compiler/modecheck_unify.m:
Relax the locking of non-locals when processing non-ground lambda
goals.
Update documentation.
compiler/mode_util.m:
Propagate type information into the pred_inst_infos of any insts.
compiler/mode_errors.m:
Change the purity error "lambda should be impure" to "lambda
should be any", since this is better advice. Also provide an
example of correct syntax if the verbose errors option is given.
compiler/prog_io_goal.m:
Parse the new kinds of expressions, returning the groundness along
with the existing information about lambda expressions.
compiler/superhomogeneous.m:
Use the above groundness when building the lambda unification.
compiler/prog_io_util.m:
Parse the new kind of insts, filling in the new ho_inst_info field
where appropriate.
compiler/polymorphism.m:
Handle the new fields. Assume that the shorthand form of lambda
expressions always defines a ground inst -- if users want non-ground
higher-order expressions they will need to use an explicit any_pred
or any_func expression.
compiler/equiv_type_hlds.m:
Replace equivalent types in the pred_inst_infos of `any' insts.
compiler/module_qual.m:
Module qualify the pred_inst_infos of `any' insts.
compiler/recompilation.usage.m:
compiler/unused_imports.m:
Look for items or imports used by insts in the pred_inst_infos of
`any' insts.
compiler/hlds_out.m:
compiler/mercury_to_mercury.m:
Output the new lambda expressions and insts in the correct format.
compiler/type_util.m:
Treat all pred and func types as solver types. (Effectively they
are, since all such types can now have non-ground values, with
call/N and apply/N acting as constraints.)
compiler/lambda.m:
Pass the groundness value when building procedures for lambda
expressions. This is not currently required for anything.
doc/reference_manual.texi:
Document the new feature, and update existing documentation on
solver types and negated contexts.
compiler/add_pragma.m:
compiler/assertion.m:
compiler/build_mode_constraints.m:
compiler/cse_detection.m:
compiler/dead_proc_elim.m:
compiler/delay_partial_inst.m:
compiler/det_analysis.m:
compiler/det_util.m:
compiler/goal_path.m:
compiler/goal_util.m:
compiler/hhf.m:
compiler/hlds_code_util.m:
compiler/inst_check.m:
compiler/intermod.m:
compiler/lco.m:
compiler/loop_inv.m:
compiler/make_hlds_warn.m:
compiler/mode_constraints.m:
compiler/mode_ordering.m:
compiler/modes.m:
compiler/pd_util.m:
compiler/post_typecheck.m:
compiler/prog_io.m:
compiler/prog_mode.m:
compiler/purity.m:
compiler/qual_info.m:
compiler/quantification.m:
compiler/simplify.m:
compiler/stratify.m:
compiler/switch_detection.m:
compiler/typecheck.m:
compiler/unify_proc.m:
compiler/unique_modes.m:
compiler/unused_args.m:
compiler/xml_documentation.m:
Handle the new fields.
tests/valid/Mmakefile:
tests/valid/ho_any_inst.m:
New test case for some valid code using higher-order any insts.
tests/invalid/Mmakefile:
tests/invalid/ho_any_inst.err_exp:
tests/invalid/ho_any_inst.m:
New test case for some illegal code.
tests/invalid/anys_in_negated_contexts.err_exp:
Update expected error message for this test case. We now report
that the expression should be `any', rather than impure.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.76
diff -u -r1.76 add_pragma.m
--- compiler/add_pragma.m 31 Dec 2007 10:03:45 -0000 1.76
+++ compiler/add_pragma.m 8 Jan 2008 10:29:35 -0000
@@ -3613,7 +3613,7 @@
:- pred match_corresponding_bound_inst_lists_with_renaming(module_info::in,
list(bound_inst)::in, list(bound_inst)::in,
- inst_var_renaming::in,inst_var_renaming::out) is semidet.
+ inst_var_renaming::in, inst_var_renaming::out) is semidet.
match_corresponding_bound_inst_lists_with_renaming(_, [], [], !Renaming).
match_corresponding_bound_inst_lists_with_renaming(ModuleInfo,
@@ -3629,7 +3629,11 @@
:- pred match_insts_with_renaming(module_info::in, mer_inst::in, mer_inst::in,
map(inst_var, inst_var)::out) is semidet.
-match_insts_with_renaming(_, any(Uniq), any(Uniq), map.init).
+match_insts_with_renaming(ModuleInfo, InstA, InstB, Renaming) :-
+ InstA = any(Uniq, HOInstInfoA),
+ InstB = any(Uniq, HOInstInfoB),
+ match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
+ Renaming).
match_insts_with_renaming(_, free, free, map.init).
match_insts_with_renaming(_, free(Type), free(Type), map.init).
match_insts_with_renaming(ModuleInfo, InstA, InstB, Renaming) :-
@@ -3638,19 +3642,10 @@
match_corresponding_bound_inst_lists_with_renaming(ModuleInfo,
BoundInstsA, BoundInstsB, map.init, Renaming).
match_insts_with_renaming(ModuleInfo, InstA, InstB, Renaming) :-
- InstA = ground(Uniq, GroundInstInfoA),
- InstB = ground(Uniq, GroundInstInfoB),
- (
- GroundInstInfoA = none,
- GroundInstInfoB = none,
- Renaming = map.init
- ;
- GroundInstInfoA = higher_order(PredInstInfoA),
- GroundInstInfoB = higher_order(PredInstInfoB),
- PredInstInfoA = pred_inst_info(PredOrFunc, ModesA, Det),
- PredInstInfoB = pred_inst_info(PredOrFunc, ModesB, Det),
- mode_list_matches_with_renaming(ModesA, ModesB, Renaming, ModuleInfo)
- ).
+ InstA = ground(Uniq, HOInstInfoA),
+ InstB = ground(Uniq, HOInstInfoB),
+ match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
+ Renaming).
match_insts_with_renaming(_, not_reached, not_reached, map.init).
match_insts_with_renaming(_, inst_var(VarA), inst_var(VarB), Subst) :-
svmap.insert(VarA, VarB, map.init, Subst).
@@ -3691,6 +3686,23 @@
match_corresponding_inst_lists_with_renaming(ModuleInfo, ArgsA, ArgsB,
map.init, Renaming).
+:- pred match_ho_inst_infos_with_renaming(module_info::in, ho_inst_info::in,
+ ho_inst_info::in, map(inst_var, inst_var)::out) is semidet.
+
+match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
+ Renaming) :-
+ (
+ HOInstInfoA = none,
+ HOInstInfoB = none,
+ Renaming = map.init
+ ;
+ HOInstInfoA = higher_order(PredInstInfoA),
+ HOInstInfoB = higher_order(PredInstInfoB),
+ PredInstInfoA = pred_inst_info(PredOrFunc, ModesA, Det),
+ PredInstInfoB = pred_inst_info(PredOrFunc, ModesB, Det),
+ mode_list_matches_with_renaming(ModesA, ModesB, Renaming, ModuleInfo)
+ ).
+
:- pred match_inst_names_with_renaming(module_info::in,
inst_name::in, inst_name::in, inst_var_renaming::out) is semidet.
Index: compiler/assertion.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/assertion.m,v
retrieving revision 1.59
diff -u -r1.59 assertion.m
--- compiler/assertion.m 30 Dec 2007 08:23:31 -0000 1.59
+++ compiler/assertion.m 8 Jan 2008 10:29:35 -0000
@@ -598,9 +598,9 @@
!Subst) :-
equal_vars(VarsA, VarsB, !Subst).
equal_unification(LambdaGoalA, LambdaGoalB, !Subst) :-
- LambdaGoalA = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ LambdaGoalA = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NLVarsA, LVarsA, Modes, Det, GoalA),
- LambdaGoalB = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ LambdaGoalB = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NLVarsB, LVarsB, Modes, Det, GoalB),
equal_vars(NLVarsA, NLVarsB, !Subst),
equal_vars(LVarsA, LVarsB, !Subst),
Index: compiler/build_mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/build_mode_constraints.m,v
retrieving revision 1.29
diff -u -r1.29 build_mode_constraints.m
--- compiler/build_mode_constraints.m 30 Dec 2007 08:23:31 -0000 1.29
+++ compiler/build_mode_constraints.m 8 Jan 2008 10:29:35 -0000
@@ -524,7 +524,7 @@
% - it could be a test, so no constraints.
)
;
- RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _),
+ RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
sorry(this_file, "unify with lambda goal")
).
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.113
diff -u -r1.113 cse_detection.m
--- compiler/cse_detection.m 30 Dec 2007 08:23:34 -0000 1.113
+++ compiler/cse_detection.m 8 Jan 2008 10:29:35 -0000
@@ -257,13 +257,13 @@
detect_cse_in_goal_2(unify(LHS, RHS0, Mode, Unify, UnifyContext), _, InstMap0,
!CseInfo, Redo, unify(LHS, RHS, Mode,Unify, UnifyContext)) :-
(
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars,
- Vars, Modes, Det, Goal0),
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocalVars, Vars, Modes, Det, Goal0),
ModuleInfo = !.CseInfo ^ module_info,
instmap.pre_lambda_update(ModuleInfo, Vars, Modes, InstMap0, InstMap),
detect_cse_in_goal(Goal0, InstMap, !CseInfo, Redo, Goal),
- RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars,
- Vars, Modes, Det, Goal)
+ RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocalVars, Vars, Modes, Det, Goal)
;
( RHS0 = rhs_var(_)
; RHS0 = rhs_functor(_, _, _)
@@ -600,7 +600,7 @@
GoalExpr1 = unify(Var, RHS, Umode, Unif, Ucontext)
;
( RHS = rhs_var(_)
- ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _)
+ ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
),
unexpected(this_file,
"non-functor unify in construct_common_unify")
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.125
diff -u -r1.125 dead_proc_elim.m
--- compiler/dead_proc_elim.m 30 Dec 2007 08:23:34 -0000 1.125
+++ compiler/dead_proc_elim.m 8 Jan 2008 10:29:35 -0000
@@ -1068,7 +1068,7 @@
;
true
).
-pre_modecheck_examine_unify_rhs(rhs_lambda_goal(_, _, _, _, _, _, _, Goal),
+pre_modecheck_examine_unify_rhs(rhs_lambda_goal(_, _, _, _, _, _, _, _, Goal),
!DeadInfo) :-
pre_modecheck_examine_goal(Goal, !DeadInfo).
Index: compiler/delay_partial_inst.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/delay_partial_inst.m,v
retrieving revision 1.5
diff -u -r1.5 delay_partial_inst.m
--- compiler/delay_partial_inst.m 30 Dec 2007 08:23:35 -0000 1.5
+++ compiler/delay_partial_inst.m 8 Jan 2008 10:29:35 -0000
@@ -339,16 +339,16 @@
else
(
% Tranform lambda goals as well. Non-local variables in
- % lambda goals must be ground so we don't carry the
+ % lambda goals must be any or ground so we don't carry the
% construct map into the lambda goal.
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
- NonLocals, LambdaQuantVars, Modues, Detism,
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc,
+ EvalMethod, NonLocals, LambdaQuantVars, Modues, Detism,
LambdaGoal0),
delay_partial_inst_in_goal(InstMap0,
LambdaGoal0, LambdaGoal, map.init, _ConstructMap,
!DelayInfo),
- RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
- NonLocals, LambdaQuantVars, Modues, Detism,
+ RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc,
+ EvalMethod, NonLocals, LambdaQuantVars, Modues, Detism,
LambdaGoal),
GoalExpr = unify(LHS, RHS, Mode, Unify, Context),
Goal = hlds_goal(GoalExpr, GoalInfo0)
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.210
diff -u -r1.210 det_analysis.m
--- compiler/det_analysis.m 30 Dec 2007 08:23:36 -0000 1.210
+++ compiler/det_analysis.m 8 Jan 2008 10:29:35 -0000
@@ -1153,8 +1153,8 @@
!DetInfo, !Specs) :-
% Unifications are either deterministic or semideterministic.
(
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars,
- Vars, Modes, LambdaDeclaredDet, Goal0),
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocalVars, Vars, Modes, LambdaDeclaredDet, Goal0),
( determinism_components(LambdaDeclaredDet, _, at_most_many_cc) ->
LambdaSolnContext = first_soln
;
@@ -1166,8 +1166,8 @@
no, LambdaInferredDet, _LambdaFailingContexts, !DetInfo, !Specs),
det_check_lambda(LambdaDeclaredDet, LambdaInferredDet,
Goal, GoalInfo, InstMap1, !DetInfo, !Specs),
- RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocalVars,
- Vars, Modes, LambdaDeclaredDet, Goal)
+ RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocalVars, Vars, Modes, LambdaDeclaredDet, Goal)
;
( RHS0 = rhs_var(_)
; RHS0 = rhs_functor(_, _, _)
@@ -1198,7 +1198,7 @@
GoalFailingContexts = [FailingContext]
;
( RHS = rhs_functor(_, _, _)
- ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _)
+ ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
),
unexpected(this_file, "complicated_unify but no var")
)
Index: compiler/det_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_util.m,v
retrieving revision 1.45
diff -u -r1.45 det_util.m
--- compiler/det_util.m 30 Dec 2007 08:23:36 -0000 1.45
+++ compiler/det_util.m 8 Jan 2008 10:29:35 -0000
@@ -137,7 +137,7 @@
term.var_list_to_term_list(ArgVars, ArgTerms),
cons_id_and_args_to_term(ConsId, ArgTerms, RhsTerm),
unify_term(variable(X, context_init), RhsTerm, !Subst).
-interpret_unify(_X, rhs_lambda_goal(_, _, _, _, _, _, _, _), !Subst).
+interpret_unify(_X, rhs_lambda_goal(_, _, _, _, _, _, _, _, _), !Subst).
% For ease of implementation we just ignore unifications with lambda terms.
% This is a safe approximation, it just prevents us from optimizing them
% as well as we would like.
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.47
diff -u -r1.47 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 30 Dec 2007 08:23:37 -0000 1.47
+++ compiler/equiv_type_hlds.m 8 Jan 2008 10:29:35 -0000
@@ -481,7 +481,10 @@
%
:- func type_may_occur_in_inst(mer_inst) = bool.
-type_may_occur_in_inst(any(_)) = no.
+type_may_occur_in_inst(any(_, none)) = no.
+type_may_occur_in_inst(any(_, higher_order(_PredInstInfo))) = no.
+ % This is a conservative approximation; the mode in _PredInstInfo
+ % may contain a reference to a type.
type_may_occur_in_inst(free) = no.
type_may_occur_in_inst(free(_)) = yes.
type_may_occur_in_inst(bound(_, BoundInsts)) =
@@ -532,15 +535,26 @@
:- pred replace_in_inst_2(eqv_map::in, mer_inst::in, mer_inst::out, bool::out,
tvarset::in, tvarset::out, inst_cache::in, inst_cache::out) is det.
-replace_in_inst_2(_, any(_) @ Inst, Inst, no, !TVarSet, !Cache).
+replace_in_inst_2(_, any(_, none) @ Inst, Inst, no, !TVarSet, !Cache).
+replace_in_inst_2(EqvMap, any(Uniq, higher_order(PredInstInfo0)) @ Inst0, Inst,
+ Changed, !TVarSet, !Cache) :-
+ PredInstInfo0 = pred_inst_info(PorF, Modes0, Det),
+ replace_in_modes(EqvMap, Modes0, Modes, Changed, !TVarSet, !Cache),
+ (
+ Changed = yes,
+ Inst = any(Uniq, higher_order(pred_inst_info(PorF, Modes, Det)))
+ ;
+ Changed = no,
+ Inst = Inst0
+ ).
replace_in_inst_2(_, free @ Inst, Inst, no, !TVarSet, !Cache).
-replace_in_inst_2(EqvMap, Inst0 @ free(Type0), Inst, Changed,
+replace_in_inst_2(EqvMap, free(Type0) @ Inst0, Inst, Changed,
!TVarSet, !Cache) :-
equiv_type.replace_in_type(EqvMap, Type0, Type, Changed, !TVarSet, no, _),
( Changed = yes, Inst = free(Type)
; Changed = no, Inst = Inst0
).
-replace_in_inst_2(EqvMap, Inst0 @ bound(Uniq, BoundInsts0), Inst,
+replace_in_inst_2(EqvMap, bound(Uniq, BoundInsts0) @ Inst0, Inst,
Changed, !TVarSet, !Cache) :-
replace_in_bound_insts(EqvMap, BoundInsts0, BoundInsts, Changed, !TVarSet,
!Cache),
@@ -548,10 +562,9 @@
; Changed = no, Inst = Inst0
).
replace_in_inst_2(_, ground(_, none) @ Inst, Inst, no, !TVarSet, !Cache).
-replace_in_inst_2(EqvMap,
- Inst0 @ ground(Uniq,
- higher_order(pred_inst_info(PorF, Modes0, Det))),
+replace_in_inst_2(EqvMap, ground(Uniq, higher_order(PredInstInfo0)) @ Inst0,
Inst, Changed, !TVarSet, !Cache) :-
+ PredInstInfo0 = pred_inst_info(PorF, Modes0, Det),
replace_in_modes(EqvMap, Modes0, Modes, Changed, !TVarSet, !Cache),
(
Changed = yes,
@@ -562,7 +575,7 @@
).
replace_in_inst_2(_, not_reached @ Inst, Inst, no, !TVarSet, !Cache).
replace_in_inst_2(_, inst_var(_) @ Inst, Inst, no, !TVarSet, !Cache).
-replace_in_inst_2(EqvMap, Inst0 @ constrained_inst_vars(Vars, CInst0), Inst,
+replace_in_inst_2(EqvMap, constrained_inst_vars(Vars, CInst0) @ Inst0, Inst,
Changed, !TVarSet, !Cache) :-
replace_in_inst(EqvMap, CInst0, CInst, Changed, !TVarSet, !Cache),
( Changed = yes, Inst = constrained_inst_vars(Vars, CInst)
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.47
diff -u -r1.47 goal_path.m
--- compiler/goal_path.m 30 Dec 2007 08:23:39 -0000 1.47
+++ compiler/goal_path.m 8 Jan 2008 10:29:35 -0000
@@ -192,9 +192,9 @@
;
Goal0 = unify(LHS, RHS0, Mode, Kind, Context),
(
- RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal0),
+ RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, H, LambdaGoal0),
fill_goal_slots(Path0, SlotInfo, LambdaGoal0, LambdaGoal),
- RHS = rhs_lambda_goal(A, B, C, D, E, F, G, LambdaGoal)
+ RHS = rhs_lambda_goal(A, B, C, D, E, F, G, H, LambdaGoal)
;
( RHS0 = rhs_var(_)
; RHS0 = rhs_functor(_, _, _)
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.153
diff -u -r1.153 goal_util.m
--- compiler/goal_util.m 30 Dec 2007 08:23:39 -0000 1.153
+++ compiler/goal_util.m 8 Jan 2008 10:29:35 -0000
@@ -566,7 +566,7 @@
RHS = rhs_functor(_Functor, _, ArgVars),
svset.insert_list(ArgVars, !Set).
rhs_goal_vars(RHS, !Set) :-
- RHS = rhs_lambda_goal(_, _, _, NonLocals, LambdaVars, _, _, Goal),
+ RHS = rhs_lambda_goal(_, _, _, _, NonLocals, LambdaVars, _, _, Goal),
svset.insert_list(NonLocals, !Set),
svset.insert_list(LambdaVars, !Set),
goal_vars_2(Goal ^ hlds_goal_expr, !Set).
Index: compiler/hhf.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hhf.m,v
retrieving revision 1.33
diff -u -r1.33 hhf.m
--- compiler/hhf.m 30 Dec 2007 08:23:40 -0000 1.33
+++ compiler/hhf.m 8 Jan 2008 10:29:35 -0000
@@ -291,10 +291,10 @@
process_unify(rhs_var(Y), _, _, X, Mode, Unif, Context, GoalExpr, !HI) :-
GoalExpr = unify(X, rhs_var(Y), Mode, Unif, Context).
-process_unify(rhs_lambda_goal(A,B,C,D,E,F,G,LambdaGoal0), NonLocals, _, X,
+process_unify(rhs_lambda_goal(A,B,C,D,E,F,G,H,LambdaGoal0), NonLocals, _, X,
Mode, Unif, Context, GoalExpr, !HI) :-
process_goal(NonLocals, LambdaGoal0, LambdaGoal, !HI),
- GoalExpr = unify(X, rhs_lambda_goal(A,B,C,D,E,F,G,LambdaGoal), Mode,
+ GoalExpr = unify(X, rhs_lambda_goal(A,B,C,D,E,F,G,H,LambdaGoal), Mode,
Unif, Context).
process_unify(rhs_functor(ConsId0, IsExistConstruct, ArgsA), NonLocals,
GoalInfo0, X, Mode, Unif, Context, GoalExpr, !HI) :-
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.36
diff -u -r1.36 hlds_code_util.m
--- compiler/hlds_code_util.m 30 Dec 2007 08:23:41 -0000 1.36
+++ compiler/hlds_code_util.m 8 Jan 2008 10:29:35 -0000
@@ -184,7 +184,7 @@
:- pred is_valid_mutable_inst_2(module_info::in, mer_inst::in,
set(inst_name)::in) is semidet.
-is_valid_mutable_inst_2(_, any(shared), _).
+is_valid_mutable_inst_2(_, any(shared, _), _).
is_valid_mutable_inst_2(ModuleInfo, bound(shared, BoundInsts), Expansions) :-
list.member(bound_functor(_, Insts), BoundInsts),
list.member(Inst, Insts),
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.185
diff -u -r1.185 hlds_goal.m
--- compiler/hlds_goal.m 30 Dec 2007 08:23:42 -0000 1.185
+++ compiler/hlds_goal.m 8 Jan 2008 10:29:35 -0000
@@ -505,6 +505,9 @@
)
; rhs_lambda_goal(
rhs_purity :: purity,
+ rhs_groundness :: ho_groundness,
+ % Whether this closure is `ground' or
+ % `any'.
rhs_p_or_f :: pred_or_func,
rhs_eval_method :: lambda_eval_method,
% Currently, we don't support any other
@@ -2231,9 +2234,9 @@
rhs_functor(Functor, E, ArgVars0), rhs_functor(Functor, E, ArgVars)) :-
rename_var_list(Must, Subn, ArgVars0, ArgVars).
rename_unify_rhs(Must, Subn,
- rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NonLocals0, Vars0, Modes, Det, Goal0),
- rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NonLocals, Vars, Modes, Det, Goal)) :-
rename_var_list(Must, Subn, NonLocals0, NonLocals),
rename_var_list(Must, Subn, Vars0, Vars),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.441
diff -u -r1.441 hlds_out.m
--- compiler/hlds_out.m 31 Dec 2007 10:03:46 -0000 1.441
+++ compiler/hlds_out.m 8 Jan 2008 10:29:35 -0000
@@ -2610,20 +2610,27 @@
;
true
).
-write_unify_rhs_3(rhs_lambda_goal(Purity, PredOrFunc, _EvalMethod, NonLocals,
- Vars, Modes, Det, Goal), ModuleInfo, VarSet, InstVarSet,
+write_unify_rhs_3(rhs_lambda_goal(Purity, Groundness, PredOrFunc, _EvalMethod,
+ NonLocals, Vars, Modes, Det, Goal), ModuleInfo, VarSet, InstVarSet,
AppendVarNums, Indent, MaybeType, TypeQual, !IO) :-
Indent1 = Indent + 1,
write_purity_prefix(Purity, !IO),
(
PredOrFunc = pf_predicate,
+ (
+ Groundness = ho_ground,
+ Functor = "pred"
+ ;
+ Groundness = ho_any,
+ Functor = "any_pred"
+ ),
io.write_string("(", !IO),
(
Vars = [],
- io.write_string("(pred)", !IO)
+ io.write_strings(["(", Functor, ")"], !IO)
;
Vars = [_ | _],
- io.write_string("pred(", !IO),
+ io.write_strings([Functor, "("], !IO),
write_var_modes(Vars, Modes, VarSet, InstVarSet, AppendVarNums,
!IO),
io.write_string(")", !IO)
@@ -2637,15 +2644,22 @@
io.write_string(")", !IO)
;
PredOrFunc = pf_function,
+ (
+ Groundness = ho_ground,
+ Functor = "func"
+ ;
+ Groundness = ho_any,
+ Functor = "any_func"
+ ),
pred_args_to_func_args(Modes, ArgModes, RetMode),
pred_args_to_func_args(Vars, ArgVars, RetVar),
io.write_string("(", !IO),
(
ArgVars = [],
- io.write_string("(func)", !IO)
+ io.write_strings(["(", Functor, ")"], !IO)
;
ArgVars = [_ | _],
- io.write_string("func(", !IO),
+ io.write_strings([Functor, "("], !IO),
write_var_modes(ArgVars, ArgModes, VarSet, InstVarSet,
AppendVarNums, !IO),
io.write_string(")", !IO)
@@ -2699,7 +2713,7 @@
),
Str = functor_cons_id_to_string(ConsId, ArgVars, VarSet, ModuleInfo,
AppendVarNums).
-unify_rhs_to_string(rhs_lambda_goal(_, _, _, _, _, _, _, _), _, _, _)
+unify_rhs_to_string(rhs_lambda_goal(_, _, _, _, _, _, _, _, _), _, _, _)
= "lambda goal".
:- pred write_sym_name_and_args(sym_name::in, list(prog_var)::in,
@@ -4329,8 +4343,14 @@
:- func inst_to_term_with_context(mer_inst, prog_context) = prog_term.
-inst_to_term_with_context(any(Uniq), Context) =
- make_atom(any_inst_uniqueness(Uniq), Context).
+inst_to_term_with_context(any(Uniq, HOInstInfo), Context) = Term :-
+ (
+ HOInstInfo = higher_order(PredInstInfo),
+ Term = any_pred_inst_info_to_term(Uniq, PredInstInfo, Context)
+ ;
+ HOInstInfo = none,
+ Term = make_atom(any_inst_uniqueness(Uniq), Context)
+ ).
inst_to_term_with_context(free, Context) =
make_atom("free", Context).
inst_to_term_with_context(free(Type), Context) = Term :-
@@ -4340,29 +4360,12 @@
inst_to_term_with_context(bound(Uniq, BoundInsts), Context) = Term :-
construct_qualified_term(unqualified(inst_uniqueness(Uniq, "bound")),
[bound_insts_to_term(BoundInsts, Context)], Context, Term).
-inst_to_term_with_context(ground(Uniq, GroundInstInfo), Context) = Term :-
+inst_to_term_with_context(ground(Uniq, HOInstInfo), Context) = Term :-
(
- GroundInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)),
- % XXX we ignore Uniq
- (
- PredOrFunc = pf_predicate,
- construct_qualified_term(unqualified("pred"),
- list.map(mode_to_term_with_context(Context), Modes),
- Context, ModesTerm)
- ;
- PredOrFunc = pf_function,
- pred_args_to_func_args(Modes, ArgModes, RetMode),
- construct_qualified_term(unqualified("func"),
- list.map(mode_to_term_with_context(Context), ArgModes),
- Context, ArgModesTerm),
- construct_qualified_term(unqualified("="),
- [ArgModesTerm, mode_to_term_with_context(Context, RetMode)],
- Context, ModesTerm)
- ),
- construct_qualified_term(unqualified("is"), [
- ModesTerm, det_to_term(Det, Context)], Context, Term)
+ HOInstInfo = higher_order(PredInstInfo),
+ Term = ground_pred_inst_info_to_term(Uniq, PredInstInfo, Context)
;
- GroundInstInfo = none,
+ HOInstInfo = none,
Term = make_atom(inst_uniqueness(Uniq, "ground"), Context)
).
inst_to_term_with_context(inst_var(Var), _) =
@@ -4379,6 +4382,54 @@
inst_to_term_with_context(not_reached, Context) =
make_atom("not_reached", Context).
+:- func ground_pred_inst_info_to_term(uniqueness, pred_inst_info, prog_context)
+ = prog_term.
+
+ground_pred_inst_info_to_term(_Uniq, PredInstInfo, Context) = Term :-
+ % XXX we ignore Uniq
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ (
+ PredOrFunc = pf_predicate,
+ construct_qualified_term(unqualified("pred"),
+ list.map(mode_to_term_with_context(Context), Modes),
+ Context, ModesTerm)
+ ;
+ PredOrFunc = pf_function,
+ pred_args_to_func_args(Modes, ArgModes, RetMode),
+ construct_qualified_term(unqualified("func"),
+ list.map(mode_to_term_with_context(Context), ArgModes),
+ Context, ArgModesTerm),
+ construct_qualified_term(unqualified("="),
+ [ArgModesTerm, mode_to_term_with_context(Context, RetMode)],
+ Context, ModesTerm)
+ ),
+ construct_qualified_term(unqualified("is"),
+ [ModesTerm, det_to_term(Det, Context)], Context, Term).
+
+:- func any_pred_inst_info_to_term(uniqueness, pred_inst_info, prog_context)
+ = prog_term.
+
+any_pred_inst_info_to_term(_Uniq, PredInstInfo, Context) = Term :-
+ % XXX we ignore Uniq
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ (
+ PredOrFunc = pf_predicate,
+ construct_qualified_term(unqualified("any_pred"),
+ list.map(mode_to_term_with_context(Context), Modes),
+ Context, ModesTerm)
+ ;
+ PredOrFunc = pf_function,
+ pred_args_to_func_args(Modes, ArgModes, RetMode),
+ construct_qualified_term(unqualified("any_func"),
+ list.map(mode_to_term_with_context(Context), ArgModes),
+ Context, ArgModesTerm),
+ construct_qualified_term(unqualified("="),
+ [ArgModesTerm, mode_to_term_with_context(Context, RetMode)],
+ Context, ModesTerm)
+ ),
+ construct_qualified_term(unqualified("is"),
+ [ModesTerm, det_to_term(Det, Context)], Context, Term).
+
:- func inst_name_to_term(inst_name, prog_context) = prog_term.
inst_name_to_term(user_inst(Name, Args), Context) = Term :-
Index: compiler/inst_check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_check.m,v
retrieving revision 1.8
diff -u -r1.8 inst_check.m
--- compiler/inst_check.m 30 Dec 2007 08:23:43 -0000 1.8
+++ compiler/inst_check.m 8 Jan 2008 10:29:35 -0000
@@ -136,7 +136,7 @@
true
)
;
- ( Inst = any(_)
+ ( Inst = any(_, _)
; Inst = free
; Inst = free(_)
; Inst = ground(_, _)
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.83
diff -u -r1.83 inst_match.m
--- compiler/inst_match.m 30 Dec 2007 08:23:43 -0000 1.83
+++ compiler/inst_match.m 8 Jan 2008 10:29:35 -0000
@@ -87,7 +87,7 @@
is semidet.
% This version of inst_matches_initial does not allow implied modes. This
- % makes it almost the same as inst_matches_final. The only different is
+ % makes it almost the same as inst_matches_final. The only difference is
% in the way it handles constrained_inst_vars.
%
:- pred inst_matches_initial_no_implied_modes(mer_inst::in, mer_inst::in,
@@ -543,18 +543,22 @@
% inst_matches_initial is true for any pairs of insts which
% occur in `Expansions'.
-inst_matches_initial_4(any(UniqA), any(UniqB), _, !Info) :-
+inst_matches_initial_4(any(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB), Type,
+ !Info) :-
!.Info ^ any_matches_any = yes,
- compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB).
-inst_matches_initial_4(any(_), free, _, !Info).
-inst_matches_initial_4(any(UniqA), ground(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+ compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB),
+ ho_inst_info_matches_initial(HOInstInfoA, HOInstInfoB, UniqB, Type, !Info).
+inst_matches_initial_4(any(_, _), free, _, !Info).
+inst_matches_initial_4(any(UniqA, HOInstInfoA), ground(_, _)@InstB, Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_initial_2(InstA, InstB, Type, !Info).
-inst_matches_initial_4(any(UniqA), bound(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+inst_matches_initial_4(any(UniqA, HOInstInfoA), bound(_, _)@InstB, Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_initial_2(InstA, InstB, Type, !Info).
inst_matches_initial_4(free, free, _, !Info).
-inst_matches_initial_4(bound(UniqA, ListA), any(UniqB), _, !Info) :-
+inst_matches_initial_4(bound(UniqA, ListA), any(UniqB, none), _, !Info) :-
compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB),
compare_bound_inst_list_uniq(!.Info ^ uniqueness_comparison,
ListA, UniqB, !.Info ^ module_info).
@@ -577,10 +581,10 @@
Uniq = mostly_unique,
bound_inst_list_is_ground(List, !.Info ^ module_info),
bound_inst_list_is_mostly_unique(List, !.Info ^ module_info).
-inst_matches_initial_4(ground(UniqA, GroundInstInfoA), any(UniqB), _, !Info) :-
- \+ ground_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
- GroundInstInfoA),
- compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB).
+inst_matches_initial_4(ground(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB),
+ Type, !Info) :-
+ compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB),
+ ho_inst_info_matches_initial(HOInstInfoA, HOInstInfoB, UniqB, Type, !Info).
inst_matches_initial_4(ground(_Uniq, _PredInst), free, _, !Info).
inst_matches_initial_4(ground(UniqA, _GII_A), bound(UniqB, ListB), MaybeType,
!Info) :-
@@ -591,16 +595,15 @@
ListB, Type),
ground_matches_initial_bound_inst_list(UniqA, ListB, yes(Type),
!Info).
-inst_matches_initial_4(ground(UniqA, GroundInstInfoA),
- ground(UniqB, GroundInstInfoB), Type, !Info) :-
+inst_matches_initial_4(ground(UniqA, HOInstInfoA),
+ ground(UniqB, HOInstInfoB), Type, !Info) :-
compare_uniqueness(!.Info ^ uniqueness_comparison, UniqA, UniqB),
- ground_inst_info_matches_initial(GroundInstInfoA, GroundInstInfoB,
- UniqB, Type, !Info).
+ ho_inst_info_matches_initial(HOInstInfoA, HOInstInfoB, UniqB, Type, !Info).
inst_matches_initial_4(ground(_UniqA, none), abstract_inst(_,_), _, !Info) :-
% I don't know what this should do.
% Abstract insts aren't really supported.
unexpected(this_file, "inst_matches_initial(ground, abstract_inst) == ??").
-inst_matches_initial_4(abstract_inst(_,_), any(shared), _, !Info).
+inst_matches_initial_4(abstract_inst(_,_), any(shared, none), _, !Info).
inst_matches_initial_4(abstract_inst(_,_), free, _, !Info).
inst_matches_initial_4(abstract_inst(Name, ArgsA), abstract_inst(Name, ArgsB),
_Type, !Info) :-
@@ -771,24 +774,23 @@
%-----------------------------------------------------------------------------%
- % This predicate checks if two ground_inst_infos match_initial.
+ % This predicate checks if two ho_inst_infos match_initial.
% It does not check uniqueness.
%
-:- pred ground_inst_info_matches_initial(ground_inst_info::in,
- ground_inst_info::in, uniqueness::in, maybe(mer_type)::in,
+:- pred ho_inst_info_matches_initial(ho_inst_info::in,
+ ho_inst_info::in, uniqueness::in, maybe(mer_type)::in,
inst_match_info::in, inst_match_info::out) is semidet.
-ground_inst_info_matches_initial(GroundInstInfoA, none, _, _, !Info) :-
- \+ ground_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
- GroundInstInfoA).
-ground_inst_info_matches_initial(none, higher_order(PredInstB), _, Type,
- !Info) :-
+ho_inst_info_matches_initial(HOInstInfoA, none, _, _, !Info) :-
+ \+ ho_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
+ HOInstInfoA).
+ho_inst_info_matches_initial(none, higher_order(PredInstB), _, Type, !Info) :-
PredInstB = pred_inst_info(pf_function, ArgModes, _Det),
Arity = list.length(ArgModes),
PredInstA = pred_inst_info_standard_func_mode(Arity),
pred_inst_matches_2(PredInstA, PredInstB, Type, !Info).
-ground_inst_info_matches_initial(higher_order(PredInstA),
- higher_order(PredInstB), _, MaybeType, !Info) :-
+ho_inst_info_matches_initial(higher_order(PredInstA), higher_order(PredInstB),
+ _, MaybeType, !Info) :-
pred_inst_matches_2(PredInstA, PredInstB, MaybeType, !Info).
pred_inst_matches(PredInstA, PredInstB, ModuleInfo) :-
@@ -1000,22 +1002,25 @@
:- pred inst_matches_final_3 `with_type` inst_matches_pred.
:- mode inst_matches_final_3 `with_inst` inst_matches_pred.
-inst_matches_final_3(any(UniqA), any(UniqB), _, !Info) :-
+inst_matches_final_3(any(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB), Type,
+ !Info) :-
+ ho_inst_info_matches_final(HOInstInfoA, HOInstInfoB, Type, !Info),
unique_matches_final(UniqA, UniqB).
-inst_matches_final_3(any(UniqA), ground(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+inst_matches_final_3(any(UniqA, HOInstInfoA), ground(_, _)@InstB, Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_final_2(InstA, InstB, Type, !Info).
-inst_matches_final_3(any(UniqA), bound(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+inst_matches_final_3(any(UniqA, HOInstInfoA), bound(_, _)@InstB, Type, !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_final_2(InstA, InstB, Type, !Info).
-inst_matches_final_3(free, any(Uniq), _, !Info) :-
+inst_matches_final_3(free, any(Uniq, _), _, !Info) :-
% We do not yet allow `free' to match `any',
% unless the `any' is `clobbered_any' or `mostly_clobbered_any'.
% Among other things, changing this would break compare_inst
% in modecheck_call.m.
( Uniq = clobbered ; Uniq = mostly_clobbered ).
inst_matches_final_3(free, free, _, !Info).
-inst_matches_final_3(bound(UniqA, ListA), any(UniqB), _, !Info) :-
+inst_matches_final_3(bound(UniqA, ListA), any(UniqB, none), _, !Info) :-
unique_matches_final(UniqA, UniqB),
bound_inst_list_matches_uniq(ListA, UniqB, !.Info ^ module_info),
% We do not yet allow `free' to match `any'.
@@ -1031,15 +1036,14 @@
unique_matches_final(UniqA, UniqB),
bound_inst_list_is_ground(ListA, Type, !.Info ^ module_info),
bound_inst_list_matches_uniq(ListA, UniqB, !.Info ^ module_info).
-inst_matches_final_3(ground(UniqA, GroundInstInfoA), any(UniqB), _,
- !Info) :-
- \+ ground_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
- GroundInstInfoA),
+inst_matches_final_3(ground(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB),
+ MaybeType, !Info) :-
+ ho_inst_info_matches_final(HOInstInfoA, HOInstInfoB, MaybeType, !Info),
unique_matches_final(UniqA, UniqB).
-inst_matches_final_3(ground(UniqA, GroundInstInfoA), bound(UniqB, ListB),
+inst_matches_final_3(ground(UniqA, HOInstInfoA), bound(UniqB, ListB),
MaybeType, !Info) :-
- \+ ground_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
- GroundInstInfoA),
+ \+ ho_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
+ HOInstInfoA),
unique_matches_final(UniqA, UniqB),
bound_inst_list_is_ground(ListB, MaybeType, !.Info ^ module_info),
uniq_matches_bound_inst_list(UniqA, ListB, !.Info ^ module_info),
@@ -1055,12 +1059,11 @@
% the absence of alias tracking, so we currently always
% succeed, even if this check fails.
).
-inst_matches_final_3(ground(UniqA, GroundInstInfoA),
- ground(UniqB, GroundInstInfoB), MaybeType, !Info) :-
- ground_inst_info_matches_final(GroundInstInfoA, GroundInstInfoB,
- MaybeType, !Info),
+inst_matches_final_3(ground(UniqA, HOInstInfoA), ground(UniqB, HOInstInfoB),
+ MaybeType, !Info) :-
+ ho_inst_info_matches_final(HOInstInfoA, HOInstInfoB, MaybeType, !Info),
unique_matches_final(UniqA, UniqB).
-inst_matches_final_3(abstract_inst(_, _), any(shared), _, !Info).
+inst_matches_final_3(abstract_inst(_, _), any(shared, none), _, !Info).
inst_matches_final_3(abstract_inst(Name, ArgsA), abstract_inst(Name, ArgsB),
_MaybeType, !Info) :-
list.duplicate(length(ArgsA), no, MaybeTypes),
@@ -1078,19 +1081,18 @@
inst_matches_final_2(InstA, InstB, MaybeType, !Info)
).
-:- pred ground_inst_info_matches_final(ground_inst_info::in,
- ground_inst_info::in, maybe(mer_type)::in,
- inst_match_info::in, inst_match_info::out) is semidet.
+:- pred ho_inst_info_matches_final(ho_inst_info::in, ho_inst_info::in,
+ maybe(mer_type)::in, inst_match_info::in, inst_match_info::out) is semidet.
-ground_inst_info_matches_final(GroundInstInfoA, none, _, !Info) :-
- \+ ground_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
- GroundInstInfoA).
-ground_inst_info_matches_final(none, higher_order(PredInstB), Type, !Info) :-
+ho_inst_info_matches_final(HOInstInfoA, none, _, !Info) :-
+ \+ ho_inst_info_is_nonstandard_func_mode(!.Info ^ module_info,
+ HOInstInfoA).
+ho_inst_info_matches_final(none, higher_order(PredInstB), Type, !Info) :-
PredInstB = pred_inst_info(pf_function, ArgModes, _Det),
Arity = list.length(ArgModes),
PredInstA = pred_inst_info_standard_func_mode(Arity),
pred_inst_matches_2(PredInstA, PredInstB, Type, !Info).
-ground_inst_info_matches_final(higher_order(PredInstA),
+ho_inst_info_matches_final(higher_order(PredInstA),
higher_order(PredInstB), MaybeType, !Info) :-
pred_inst_matches_2(PredInstA, PredInstB, MaybeType, !Info).
@@ -1172,25 +1174,32 @@
% Info ^ any_matches_any = yes or the type is not a solver type (and does not
% contain any solver types).
inst_matches_binding_3(free, free, _, !Info).
-inst_matches_binding_3(any(UniqA), any(UniqB), Type, !Info) :-
+inst_matches_binding_3(any(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB), Type,
+ !Info) :-
( !.Info ^ any_matches_any = yes ->
- true
+ ho_inst_info_matches_final(HOInstInfoA, HOInstInfoB, Type, !Info)
;
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, InstB),
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA,
+ InstA),
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, HOInstInfoB,
+ InstB),
inst_matches_binding_2(InstA, InstB, Type, !Info)
).
-inst_matches_binding_3(any(UniqA), ground(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+inst_matches_binding_3(any(UniqA, HOInstInfoA), ground(_, _)@InstB, Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_binding_2(InstA, InstB, Type, !Info).
-inst_matches_binding_3(any(UniqA), bound(_, _)@InstB, Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, InstA),
+inst_matches_binding_3(any(UniqA, HOInstInfoA), bound(_, _)@InstB, Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqA, HOInstInfoA, InstA),
inst_matches_binding_2(InstA, InstB, Type, !Info).
-inst_matches_binding_3(ground(_, _)@InstA, any(UniqB), Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, InstB),
+inst_matches_binding_3(ground(_, _)@InstA, any(UniqB, HOInstInfoB), Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, HOInstInfoB, InstB),
inst_matches_binding_2(InstA, InstB, Type, !Info).
-inst_matches_binding_3(bound(_, _)@InstA, any(UniqB), Type, !Info) :-
- maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, InstB),
+inst_matches_binding_3(bound(_, _)@InstA, any(UniqB, HOInstInfoB), Type,
+ !Info) :-
+ maybe_any_to_bound(Type, !.Info ^ module_info, UniqB, HOInstInfoB, InstB),
inst_matches_binding_2(InstA, InstB, Type, !Info).
inst_matches_binding_3(bound(_UniqA, ListA), bound(_UniqB, ListB), MaybeType,
!Info) :-
@@ -1213,10 +1222,10 @@
% the absence of alias tracking, so we currently always
% succeed, even if this check fails.
).
-inst_matches_binding_3(ground(_UniqA, GroundInstInfoA),
- ground(_UniqB, GroundInstInfoB), MaybeType, !Info) :-
- ground_inst_info_matches_binding(GroundInstInfoA, GroundInstInfoB,
- MaybeType, !.Info ^ module_info).
+inst_matches_binding_3(ground(_UniqA, HOInstInfoA),
+ ground(_UniqB, HOInstInfoB), MaybeType, !Info) :-
+ ho_inst_info_matches_binding(HOInstInfoA, HOInstInfoB, MaybeType,
+ !.Info ^ module_info).
inst_matches_binding_3(abstract_inst(Name, ArgsA), abstract_inst(Name, ArgsB),
_MaybeType, !Info) :-
list.duplicate(length(ArgsA), no, MaybeTypes),
@@ -1224,17 +1233,17 @@
inst_list_matches_binding(ArgsA, ArgsB, MaybeTypes, !Info).
inst_matches_binding_3(not_reached, _, _, !Info).
-:- pred ground_inst_info_matches_binding(ground_inst_info::in,
- ground_inst_info::in, maybe(mer_type)::in, module_info::in) is semidet.
+:- pred ho_inst_info_matches_binding(ho_inst_info::in, ho_inst_info::in,
+ maybe(mer_type)::in, module_info::in) is semidet.
-ground_inst_info_matches_binding(_, none, _, _).
-ground_inst_info_matches_binding(none, higher_order(PredInstB), MaybeType,
+ho_inst_info_matches_binding(_, none, _, _).
+ho_inst_info_matches_binding(none, higher_order(PredInstB), MaybeType,
ModuleInfo) :-
PredInstB = pred_inst_info(pf_function, ArgModes, _Det),
Arity = list.length(ArgModes),
PredInstA = pred_inst_info_standard_func_mode(Arity),
pred_inst_matches_1(PredInstA, PredInstB, MaybeType, ModuleInfo).
-ground_inst_info_matches_binding(higher_order(PredInstA),
+ho_inst_info_matches_binding(higher_order(PredInstA),
higher_order(PredInstB), MaybeType, ModuleInfo) :-
pred_inst_matches_1(PredInstA, PredInstB, MaybeType, ModuleInfo).
@@ -1285,8 +1294,8 @@
% is defined as one of those.
inst_is_clobbered(_, not_reached) :- fail.
-inst_is_clobbered(_, any(mostly_clobbered)).
-inst_is_clobbered(_, any(clobbered)).
+inst_is_clobbered(_, any(mostly_clobbered, _)).
+inst_is_clobbered(_, any(clobbered, _)).
inst_is_clobbered(_, ground(clobbered, _)).
inst_is_clobbered(_, ground(mostly_clobbered, _)).
inst_is_clobbered(_, bound(clobbered, _)).
@@ -1313,7 +1322,7 @@
inst_lookup(ModuleInfo, InstName, Inst),
inst_is_free(ModuleInfo, Inst).
-inst_is_any(_, any(_)).
+inst_is_any(_, any(_, _)).
inst_is_any(_, inst_var(_)) :-
unexpected(this_file, "internal error: uninstantiated inst parameter").
inst_is_any(ModuleInfo, constrained_inst_vars(_, Inst)) :-
@@ -1327,7 +1336,7 @@
% Abstract insts must be bound.
%
inst_is_bound(_, not_reached).
-inst_is_bound(_, any(_)).
+inst_is_bound(_, any(_, _)).
inst_is_bound(_, ground(_, _)).
inst_is_bound(_, bound(_, _)).
inst_is_bound(_, inst_var(_)) :-
@@ -1378,7 +1387,7 @@
( set.member(Inst, !.Expansions) ->
true
;
- ( Inst \= any(_) ->
+ ( Inst \= any(_, _) ->
svset.insert(Inst, !Expansions)
;
true
@@ -1402,8 +1411,8 @@
Inst = defined_inst(InstName),
inst_lookup(ModuleInfo, InstName, Inst2),
inst_is_ground_1(ModuleInfo, MaybeType, Inst2, !Expansions).
-inst_is_ground_2(ModuleInfo, MaybeType, any(Uniq), !Expansions) :-
- maybe_any_to_bound(MaybeType, ModuleInfo, Uniq, Inst),
+inst_is_ground_2(ModuleInfo, MaybeType, any(Uniq, HOInstInfo), !Expansions) :-
+ maybe_any_to_bound(MaybeType, ModuleInfo, Uniq, HOInstInfo, Inst),
inst_is_ground_1(ModuleInfo, MaybeType, Inst, !Expansions).
% inst_is_ground_or_any succeeds iff the inst passed is `ground',
@@ -1424,7 +1433,7 @@
bound_inst_list_is_ground_or_any_2(List, ModuleInfo,
!Expansions).
inst_is_ground_or_any_2(_, ground(_, _), !Expansions).
-inst_is_ground_or_any_2(_, any(_), !Expansions).
+inst_is_ground_or_any_2(_, any(_, _), !Expansions).
inst_is_ground_or_any_2(_, inst_var(_), !Expansions) :-
unexpected(this_file, "internal error: uninstantiated inst parameter").
inst_is_ground_or_any_2(ModuleInfo, Inst, !Expansions) :-
@@ -1456,7 +1465,7 @@
inst_is_unique_2(_, not_reached, !Expansions).
inst_is_unique_2(ModuleInfo, bound(unique, List), !Expansions) :-
bound_inst_list_is_unique_2(List, ModuleInfo, !Expansions).
-inst_is_unique_2(_, any(unique), !Expansions).
+inst_is_unique_2(_, any(unique, _), !Expansions).
inst_is_unique_2(_, free, !Expansions).
inst_is_unique_2(_, ground(unique, _), !Expansions).
inst_is_unique_2(_, inst_var(_), !Expansions) :-
@@ -1492,8 +1501,8 @@
bound_inst_list_is_mostly_unique_2(List, ModuleInfo, !Expansions).
inst_is_mostly_unique_2(ModuleInfo, bound(mostly_unique, List), !Expansions) :-
bound_inst_list_is_mostly_unique_2(List, ModuleInfo, !Expansions).
-inst_is_mostly_unique_2(_, any(unique), !Expansions).
-inst_is_mostly_unique_2(_, any(mostly_unique), !Expansions).
+inst_is_mostly_unique_2(_, any(unique, _), !Expansions).
+inst_is_mostly_unique_2(_, any(mostly_unique, _), !Expansions).
inst_is_mostly_unique_2(_, free, !Expansions).
inst_is_mostly_unique_2(_, ground(unique, _), !Expansions).
inst_is_mostly_unique_2(_, ground(mostly_unique, _), !Expansions).
@@ -1531,7 +1540,7 @@
inst_is_not_partly_unique_2(ModuleInfo, bound(shared, List), !Expansions) :-
bound_inst_list_is_not_partly_unique_2(List, ModuleInfo, !Expansions).
inst_is_not_partly_unique_2(_, free, !Expansions).
-inst_is_not_partly_unique_2(_, any(shared), !Expansions).
+inst_is_not_partly_unique_2(_, any(shared, _), !Expansions).
inst_is_not_partly_unique_2(_, ground(shared, _), !Expansions).
inst_is_not_partly_unique_2(_, inst_var(_), !Expansions) :-
unexpected(this_file, "internal error: uninstantiated inst parameter").
@@ -1571,8 +1580,8 @@
!Expansions) :-
bound_inst_list_is_not_fully_unique_2(List, ModuleInfo,
!Expansions).
-inst_is_not_fully_unique_2(_, any(shared), !Expansions).
-inst_is_not_fully_unique_2(_, any(mostly_unique), !Expansions).
+inst_is_not_fully_unique_2(_, any(shared, _), !Expansions).
+inst_is_not_fully_unique_2(_, any(mostly_unique, _), !Expansions).
inst_is_not_fully_unique_2(_, free, !Expansions).
inst_is_not_fully_unique_2(_, ground(shared, _), !Expansions).
inst_is_not_fully_unique_2(_, ground(mostly_unique, _), !Expansions).
@@ -1843,7 +1852,7 @@
bool::out, inst_names::in, inst_names::out) is det.
inst_contains_instname_2(abstract_inst(_, _), _, _, no, !Expansions).
-inst_contains_instname_2(any(_), _, _, no, !Expansions).
+inst_contains_instname_2(any(_, _), _, _, no, !Expansions).
inst_contains_instname_2(free, _, _, no, !Expansions).
inst_contains_instname_2(free(_T), _, _, no, !Expansions).
inst_contains_instname_2(ground(_Uniq, _), _, _, no, !Expansions).
@@ -1956,8 +1965,8 @@
inst_name_contains_inst_var(InstName, InstVar).
inst_contains_inst_var(bound(_Uniq, ArgInsts), InstVar) :-
bound_inst_list_contains_inst_var(ArgInsts, InstVar).
-inst_contains_inst_var(ground(_Uniq, GroundInstInfo), InstVar) :-
- GroundInstInfo = higher_order(pred_inst_info(_PredOrFunc, Modes, _Det)),
+inst_contains_inst_var(ground(_Uniq, HOInstInfo), InstVar) :-
+ HOInstInfo = higher_order(pred_inst_info(_PredOrFunc, Modes, _Det)),
mode_list_contains_inst_var(Modes, InstVar).
inst_contains_inst_var(abstract_inst(_Name, ArgInsts), InstVar) :-
inst_list_contains_inst_var(ArgInsts, InstVar).
@@ -2013,10 +2022,14 @@
% to a bound inst i where i contains all the functors of the type t and
% each argument has inst `any'.
%
+ % Note that pred and func types are considered solver types, since
+ % higher-order terms that contain non-local solver variables are
+ % themselves not ground -- they only become ground when all non-locals do.
+ %
:- pred maybe_any_to_bound(maybe(mer_type)::in, module_info::in,
- uniqueness::in, mer_inst::out) is semidet.
+ uniqueness::in, ho_inst_info::in, mer_inst::out) is semidet.
-maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, Inst) :-
+maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, none, Inst) :-
\+ type_util.is_solver_type(ModuleInfo, Type),
( type_constructors(ModuleInfo, Type, Constructors) ->
constructors_to_bound_any_insts(ModuleInfo, Uniq,
Index: compiler/inst_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_util.m,v
retrieving revision 1.55
diff -u -r1.55 inst_util.m
--- compiler/inst_util.m 30 Dec 2007 08:23:43 -0000 1.55
+++ compiler/inst_util.m 8 Jan 2008 10:29:35 -0000
@@ -128,11 +128,11 @@
:- pred pred_inst_info_is_nonstandard_func_mode(module_info::in,
pred_inst_info::in) is semidet.
- % Succeed iff the first argument is a function ground_inst_info
+ % Succeed iff the first argument is a function ho_inst_info
% whose mode does not match the standard func mode.
%
-:- pred ground_inst_info_is_nonstandard_func_mode(module_info::in,
- ground_inst_info::in) is semidet.
+:- pred ho_inst_info_is_nonstandard_func_mode(module_info::in,
+ ho_inst_info::in) is semidet.
% Return the standard mode for a function of the given arity.
%
@@ -256,12 +256,8 @@
abstractly_unify_inst_3(is_live, not_reached, _, _, not_reached, detism_det,
!ModuleInfo).
-abstractly_unify_inst_3(is_live, any(Uniq), Inst0, Real, Inst, Det,
- !ModuleInfo) :-
- make_any_inst(Inst0, is_live, Uniq, Real, Inst, Det, !ModuleInfo).
-
-abstractly_unify_inst_3(is_live, free, any(UniqY), Real, any(Uniq), detism_det,
- !ModuleInfo) :-
+abstractly_unify_inst_3(is_live, free, any(UniqY, HOInstInfo), Real,
+ any(Uniq, HOInstInfo), detism_det, !ModuleInfo) :-
unify_uniq(is_live, Real, detism_det, unique, UniqY, Uniq).
% abstractly_unify_inst_3(is_live, free, free, _, _, _, _, _) :- fail.
@@ -286,7 +282,7 @@
% abstractly_unify_inst_3(is_live, free, abstract_inst(_,_), _, _, _, _) :-
% fail.
-abstractly_unify_inst_3(is_live, bound(UniqX, List0), any(UniqY), Real,
+abstractly_unify_inst_3(is_live, bound(UniqX, List0), any(UniqY, _), Real,
bound(Uniq, List), Det, !ModuleInfo) :-
allow_unify_bound_any(Real),
unify_uniq(is_live, Real, detism_semi, UniqX, UniqY, Uniq),
@@ -321,7 +317,7 @@
% bound_inst_list_is_ground(List, !.ModuleInfo).
abstractly_unify_inst_3(is_live, ground(UniqX, higher_order(PredInst)),
- any(UniqY), Real, ground(Uniq, higher_order(PredInst)),
+ any(UniqY, _), Real, ground(Uniq, higher_order(PredInst)),
detism_semi, !ModuleInfo) :-
Real = fake_unify,
unify_uniq(is_live, Real, detism_det, UniqX, UniqY, Uniq).
@@ -340,23 +336,57 @@
det_par_conjunction_detism(Det1, detism_semi, Det).
abstractly_unify_inst_3(is_live, ground(UniqA, higher_order(PredInstA)),
- ground(UniqB, _GroundInstInfoB), Real,
- ground(Uniq, GroundInstInfo), detism_semi, !ModuleInfo) :-
+ ground(UniqB, _HOInstInfoB), Real, ground(Uniq, HOInstInfo),
+ detism_semi, !ModuleInfo) :-
% It is an error to unify higher-order preds,
% so if Real \= fake_unify, then we must fail.
Real = fake_unify,
% In theory we should choose take the union of the information specified
- % by PredInstA and _GroundInstInfoB. However, since our data representation
+ % by PredInstA and _HOInstInfoB. However, since our data representation
% provides no way of doing that, and since this will only happen for
% fake_unifys, for which it shouldn't make any difference, we just choose
% the information specified by PredInstA.
- GroundInstInfo = higher_order(PredInstA),
+ HOInstInfo = higher_order(PredInstA),
unify_uniq(is_live, Real, detism_semi, UniqA, UniqB, Uniq).
abstractly_unify_inst_3(is_live, ground(Uniq, none), Inst0, Real, Inst, Det,
!ModuleInfo) :-
make_ground_inst(Inst0, is_live, Uniq, Real, Inst, Det, !ModuleInfo).
+abstractly_unify_inst_3(is_live, any(Uniq0, higher_order(PredInst)), free,
+ Real, any(Uniq, higher_order(PredInst)), detism_det, !ModuleInfo) :-
+ unify_uniq(is_live, Real, detism_det, unique, Uniq0, Uniq).
+
+abstractly_unify_inst_3(is_live, any(UniqX, higher_order(_)),
+ bound(UniqY, BoundInsts0), Real, bound(Uniq, BoundInsts),
+ Det, !ModuleInfo) :-
+ % check `Real = fake_unify' ?
+ unify_uniq(is_live, Real, detism_semi, UniqX, UniqY, Uniq),
+ make_any_bound_inst_list(BoundInsts0, is_live, UniqX, Real, BoundInsts,
+ Det1, !ModuleInfo),
+ det_par_conjunction_detism(Det1, detism_semi, Det).
+
+abstractly_unify_inst_3(is_live, any(UniqA, higher_order(PredInstA)),
+ ground(UniqB, _HOInstInfoB), Real, ground(Uniq, HOInstInfo),
+ detism_semi, !ModuleInfo) :-
+ % See comment for the ground(_, higher_order(_)), ground(_, _) case.
+ Real = fake_unify,
+ HOInstInfo = higher_order(PredInstA),
+ unify_uniq(is_live, Real, detism_semi, UniqA, UniqB, Uniq).
+
+abstractly_unify_inst_3(is_live, any(UniqA, higher_order(PredInstA)),
+ any(UniqB, _HOInstInfoB), Real, any(Uniq, HOInstInfo), detism_semi,
+ !ModuleInfo) :-
+ % See comment for the ground(_, higher_order(_)), ground(_, _) case.
+ Real = fake_unify,
+ HOInstInfo = higher_order(PredInstA),
+ unify_uniq(is_live, Real, detism_semi, UniqA, UniqB, Uniq).
+
+abstractly_unify_inst_3(is_live, any(Uniq, none), Inst0, Real, Inst, Det,
+ !ModuleInfo) :-
+ make_any_inst(Inst0, is_live, Uniq, Real, Inst, Det, !ModuleInfo).
+
+
% abstractly_unify_inst_3(is_live, abstract_inst(_,_), free, _, _, _, _, _)
% :- fail.
@@ -379,13 +409,9 @@
abstractly_unify_inst_3(is_dead, not_reached, _, _, not_reached, detism_det,
!ModuleInfo).
-abstractly_unify_inst_3(is_dead, any(Uniq), Inst0, Real, Inst, Det,
- !ModuleInfo) :-
- make_any_inst(Inst0, is_dead, Uniq, Real, Inst, Det, !ModuleInfo).
-
abstractly_unify_inst_3(is_dead, free, Inst, _, Inst, detism_det, !ModuleInfo).
-abstractly_unify_inst_3(is_dead, bound(UniqX, List0), any(UniqY), Real,
+abstractly_unify_inst_3(is_dead, bound(UniqX, List0), any(UniqY, _), Real,
bound(Uniq, List), Det, !ModuleInfo) :-
allow_unify_bound_any(Real),
unify_uniq(is_dead, Real, detism_semi, UniqX, UniqY, Uniq),
@@ -424,7 +450,7 @@
% ).
abstractly_unify_inst_3(is_dead, ground(UniqX, higher_order(PredInst)),
- any(UniqY), Real, ground(Uniq, higher_order(PredInst)),
+ any(UniqY, _), Real, ground(Uniq, higher_order(PredInst)),
detism_semi, !ModuleInfo) :-
allow_unify_bound_any(Real),
unify_uniq(is_dead, Real, detism_semi, UniqX, UniqY, Uniq).
@@ -441,16 +467,43 @@
det_par_conjunction_detism(Det1, detism_semi, Det).
abstractly_unify_inst_3(is_dead, ground(UniqA, higher_order(PredInstA)),
- ground(UniqB, _GroundInstInfoB), Real,
- ground(Uniq, GroundInstInfo), detism_det, !ModuleInfo) :-
+ ground(UniqB, _HOInstInfoB), Real, ground(Uniq, HOInstInfo),
+ detism_det, !ModuleInfo) :-
Real = fake_unify,
- GroundInstInfo = higher_order(PredInstA),
+ HOInstInfo = higher_order(PredInstA),
unify_uniq(is_dead, Real, detism_det, UniqA, UniqB, Uniq).
abstractly_unify_inst_3(is_dead, ground(Uniq, none), Inst0, Real, Inst, Det,
!ModuleInfo) :-
make_ground_inst(Inst0, is_dead, Uniq, Real, Inst, Det, !ModuleInfo).
+abstractly_unify_inst_3(is_dead, any(UniqX, higher_order(PredInst)),
+ any(UniqY, _), Real, any(Uniq, higher_order(PredInst)),
+ detism_semi, !ModuleInfo) :-
+ unify_uniq(is_dead, Real, detism_semi, UniqX, UniqY, Uniq).
+
+abstractly_unify_inst_3(is_dead, any(Uniq, higher_order(PredInst)), free,
+ _Real, any(Uniq, higher_order(PredInst)), detism_det, !ModuleInfo).
+
+abstractly_unify_inst_3(is_dead, any(UniqA, higher_order(_)),
+ bound(UniqB, BoundInsts0), Real, bound(Uniq, BoundInsts),
+ Det, !ModuleInfo) :-
+ unify_uniq(is_dead, Real, detism_semi, UniqA, UniqB, Uniq),
+ make_any_bound_inst_list(BoundInsts0, is_dead, UniqA, Real, BoundInsts,
+ Det1, !ModuleInfo),
+ det_par_conjunction_detism(Det1, detism_semi, Det).
+
+abstractly_unify_inst_3(is_dead, any(UniqA, higher_order(PredInstA)),
+ ground(UniqB, _HOInstInfoB), Real, ground(Uniq, HOInstInfo),
+ detism_det, !ModuleInfo) :-
+ Real = fake_unify,
+ HOInstInfo = higher_order(PredInstA),
+ unify_uniq(is_dead, Real, detism_det, UniqA, UniqB, Uniq).
+
+abstractly_unify_inst_3(is_dead, any(Uniq, none), Inst0, Real, Inst, Det,
+ !ModuleInfo) :-
+ make_any_inst(Inst0, is_dead, Uniq, Real, Inst, Det, !ModuleInfo).
+
% abstract insts aren't really supported
% abstractly_unify_inst_3(is_dead, abstract_inst(N,As), bound(List), Real,
% ModuleInfo, Result, Det, ModuleInfo) :-
@@ -538,7 +591,7 @@
inst_list_is_ground_or_any_or_dead(Args0, ArgLives, !.ModuleInfo),
maybe_make_shared_inst_list(Args0, ArgLives, Args, !ModuleInfo).
-abstractly_unify_inst_functor_2(is_live, any(Uniq), ConsId, ArgInsts,
+abstractly_unify_inst_functor_2(is_live, any(Uniq, _), ConsId, ArgInsts,
ArgLives, Real, Type, Inst, Det, !ModuleInfo) :-
% We only allow `any' to unify with a functor if we know that
% the type is not a solver type.
@@ -570,7 +623,7 @@
_Real, _, bound(unique, [bound_functor(ConsId, Args)]), detism_det,
!ModuleInfo).
-abstractly_unify_inst_functor_2(is_dead, any(Uniq), ConsId, ArgInsts,
+abstractly_unify_inst_functor_2(is_dead, any(Uniq, _), ConsId, ArgInsts,
_ArgLives, Real, Type, Inst, Det, !ModuleInfo) :-
\+ type_util.is_solver_type(!.ModuleInfo, Type),
make_any_inst_list(ArgInsts, is_dead, Uniq, Real, AnyArgInsts, Det,
@@ -879,8 +932,8 @@
make_ground_inst(not_reached, _, _, _, not_reached, detism_erroneous,
!ModuleInfo).
-make_ground_inst(any(Uniq0), IsLive, Uniq1, Real, ground(Uniq, none),
- detism_semi, !ModuleInfo) :-
+make_ground_inst(any(Uniq0, HOInstInfo), IsLive, Uniq1, Real,
+ ground(Uniq, HOInstInfo), detism_semi, !ModuleInfo) :-
unify_uniq(IsLive, Real, detism_semi, Uniq0, Uniq1, Uniq).
make_ground_inst(free, IsLive, Uniq0, Real, ground(Uniq, none), detism_det,
!ModuleInfo) :-
@@ -894,8 +947,8 @@
make_ground_bound_inst_list(BoundInsts0, IsLive, Uniq1, Real,
BoundInsts, Det1, !ModuleInfo),
det_par_conjunction_detism(Det1, detism_semi, Det).
-make_ground_inst(ground(Uniq0, GroundInstInfo), IsLive, Uniq1, Real,
- ground(Uniq, GroundInstInfo), detism_semi, !ModuleInfo) :-
+make_ground_inst(ground(Uniq0, HOInstInfo), IsLive, Uniq1, Real,
+ ground(Uniq, HOInstInfo), detism_semi, !ModuleInfo) :-
unify_uniq(IsLive, Real, detism_semi, Uniq0, Uniq1, Uniq).
make_ground_inst(inst_var(_), _, _, _, _, _, _, _) :-
unexpected(this_file, "make_ground_inst: free inst var").
@@ -979,11 +1032,12 @@
module_info::in, module_info::out) is semidet.
make_any_inst(not_reached, _, _, _, not_reached, detism_erroneous, !ModuleInfo).
-make_any_inst(any(Uniq0), IsLive, Uniq1, Real, any(Uniq), detism_semi,
- !ModuleInfo) :-
+make_any_inst(any(Uniq0, HOInstInfo), IsLive, Uniq1, Real,
+ any(Uniq, HOInstInfo), detism_semi, !ModuleInfo) :-
allow_unify_bound_any(Real),
unify_uniq(IsLive, Real, detism_semi, Uniq0, Uniq1, Uniq).
-make_any_inst(free, IsLive, Uniq0, Real, any(Uniq), detism_det, !ModuleInfo) :-
+make_any_inst(free, IsLive, Uniq0, Real, any(Uniq, none), detism_det,
+ !ModuleInfo) :-
unify_uniq(IsLive, Real, detism_det, unique, Uniq0, Uniq).
make_any_inst(free(T), IsLive, Uniq, Real, defined_inst(Any), detism_det,
!ModuleInfo) :-
@@ -991,7 +1045,7 @@
% unify_uniq(IsLive, Real, detism_det, unique, Uniq0, Uniq),
% Any = typed_any(Uniq, T).
% without the need for a `typed_any' inst.
- Any = typed_inst(T, unify_inst(IsLive, free, any(Uniq), Real)).
+ Any = typed_inst(T, unify_inst(IsLive, free, any(Uniq, none), Real)).
make_any_inst(bound(Uniq0, BoundInsts0), IsLive, Uniq1, Real,
bound(Uniq, BoundInsts), Det, !ModuleInfo) :-
allow_unify_bound_any(Real),
@@ -1008,8 +1062,8 @@
make_any_inst(constrained_inst_vars(InstVars, InstConstraint), IsLive,
Uniq, Real, Inst, Det, !ModuleInfo) :-
abstractly_unify_constrained_inst_vars(IsLive, InstVars,
- InstConstraint, any(Uniq), Real, Inst, Det, !ModuleInfo).
-make_any_inst(abstract_inst(_,_), _, _, _, any(shared), detism_semi,
+ InstConstraint, any(Uniq, none), Real, Inst, Det, !ModuleInfo).
+make_any_inst(abstract_inst(_,_), _, _, _, any(shared, none), detism_semi,
!ModuleInfo).
make_any_inst(defined_inst(InstName), IsLive, Uniq, Real, Inst, Det,
!ModuleInfo) :-
@@ -1136,7 +1190,7 @@
module_info::in, module_info::out) is det.
make_shared_inst(not_reached, not_reached, !ModuleInfo).
-make_shared_inst(any(Uniq0), any(Uniq), !ModuleInfo) :-
+make_shared_inst(any(Uniq0, HOInstInfo), any(Uniq, HOInstInfo), !ModuleInfo) :-
make_shared(Uniq0, Uniq).
make_shared_inst(free, free, !ModuleInfo) :-
% The caller should ensure that this never happens.
@@ -1252,7 +1306,8 @@
% change the insts of semidet-live or nondet-live insts.)
%
make_mostly_uniq_inst(not_reached, not_reached, !ModuleInfo).
-make_mostly_uniq_inst(any(Uniq0), any(Uniq), !ModuleInfo) :-
+make_mostly_uniq_inst(any(Uniq0, HOInstInfo), any(Uniq, HOInstInfo),
+ !ModuleInfo) :-
make_mostly_uniq(Uniq0, Uniq).
make_mostly_uniq_inst(free, free, !ModuleInfo).
make_mostly_uniq_inst(free(T), free(T), !ModuleInfo).
@@ -1449,12 +1504,16 @@
% too weak -- it might not be able to detect bugs as well
% as it can currently.
-inst_merge_4(any(UniqA), any(UniqB), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(any(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB), _,
+ any(Uniq, HOInstInfo), !ModuleInfo) :-
+ merge_ho_inst_info(HOInstInfoA, HOInstInfoB, HOInstInfo, !ModuleInfo),
merge_uniq(UniqA, UniqB, Uniq).
-inst_merge_4(any(Uniq), free, _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(any(Uniq, HOInstInfo), free, _, any(Uniq, HOInstInfo),
+ !ModuleInfo) :-
% We do not yet allow merge of any with free, except for clobbered anys.
( Uniq = clobbered ; Uniq = mostly_clobbered ).
-inst_merge_4(any(UniqA), bound(UniqB, ListB), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(any(UniqA, _), bound(UniqB, ListB), _, any(Uniq, none),
+ !ModuleInfo) :-
merge_uniq_bound(UniqA, UniqB, ListB, !.ModuleInfo, Uniq),
% We do not yet allow merge of any with free, except for clobbered anys.
( ( Uniq = clobbered ; Uniq = mostly_clobbered ) ->
@@ -1462,16 +1521,21 @@
;
bound_inst_list_is_ground_or_any(ListB, !.ModuleInfo)
).
-inst_merge_4(any(UniqA), ground(UniqB, _), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(any(UniqA, HOInstInfoA), ground(UniqB, HOInstInfoB), _,
+ any(Uniq, HOInstInfo), !ModuleInfo) :-
+ merge_ho_inst_info(HOInstInfoA, HOInstInfoB, HOInstInfo, !ModuleInfo),
merge_uniq(UniqA, UniqB, Uniq).
-inst_merge_4(any(UniqA), abstract_inst(_, _), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(any(UniqA, _), abstract_inst(_, _), _, any(Uniq, none),
+ !ModuleInfo) :-
merge_uniq(UniqA, shared, Uniq),
% We do not yet allow merge of any with free, except for clobbered anys.
( Uniq = clobbered ; Uniq = mostly_clobbered ).
-inst_merge_4(free, any(Uniq), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(free, any(Uniq, HOInstInfo), _, any(Uniq, HOInstInfo),
+ !ModuleInfo) :-
% We do not yet allow merge of any with free, except for clobbered anys.
( Uniq = clobbered ; Uniq = mostly_clobbered ).
-inst_merge_4(bound(UniqA, ListA), any(UniqB), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(bound(UniqA, ListA), any(UniqB, _), _, any(Uniq, none),
+ !ModuleInfo) :-
merge_uniq_bound(UniqB, UniqA, ListA, !.ModuleInfo, Uniq),
% We do not yet allow merge of any with free, except for clobbered anys.
( ( Uniq = clobbered ; Uniq = mostly_clobbered ) ->
@@ -1479,9 +1543,12 @@
;
bound_inst_list_is_ground_or_any(ListA, !.ModuleInfo)
).
-inst_merge_4(ground(UniqA, _), any(UniqB), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(ground(UniqA, HOInstInfoA), any(UniqB, HOInstInfoB), _,
+ any(Uniq, HOInstInfo), !ModuleInfo) :-
+ merge_ho_inst_info(HOInstInfoA, HOInstInfoB, HOInstInfo, !ModuleInfo),
merge_uniq(UniqA, UniqB, Uniq).
-inst_merge_4(abstract_inst(_, _), any(UniqB), _, any(Uniq), !ModuleInfo) :-
+inst_merge_4(abstract_inst(_, _), any(UniqB, _), _, any(Uniq, none),
+ !ModuleInfo) :-
merge_uniq(shared, UniqB, Uniq),
% We do not yet allow merge of any with free, except for clobbered anys.
( Uniq = clobbered ; Uniq = mostly_clobbered ).
@@ -1498,33 +1565,9 @@
!ModuleInfo) :-
inst_merge_bound_ground(UniqB, ListB, UniqA, MaybeType, Result,
!ModuleInfo).
-inst_merge_4(ground(UniqA, GroundInstInfoA), ground(UniqB, GroundInstInfoB),
- _, ground(Uniq, GroundInstInfo), !ModuleInfo) :-
- (
- GroundInstInfoA = higher_order(PredA),
- GroundInstInfoB = higher_order(PredB)
- ->
- % If they specify matching pred insts, but one is more precise
- % (specifies more info) than the other, then we want to choose
- % the least precise one.
- ( pred_inst_matches(PredA, PredB, !.ModuleInfo) ->
- GroundInstInfo = higher_order(PredB)
- ; pred_inst_matches(PredB, PredA, !.ModuleInfo) ->
- GroundInstInfo = higher_order(PredA)
- ;
- % If either is a function inst with non-standard modes,
- % don't allow the higher-order information to be lost.
- \+ pred_inst_info_is_nonstandard_func_mode(!.ModuleInfo, PredA),
- \+ pred_inst_info_is_nonstandard_func_mode(!.ModuleInfo, PredB),
- GroundInstInfo = none
- )
- ;
- \+ ground_inst_info_is_nonstandard_func_mode(!.ModuleInfo,
- GroundInstInfoA),
- \+ ground_inst_info_is_nonstandard_func_mode(!.ModuleInfo,
- GroundInstInfoB),
- GroundInstInfo = none
- ),
+inst_merge_4(ground(UniqA, HOInstInfoA), ground(UniqB, HOInstInfoB), _,
+ ground(Uniq, HOInstInfo), !ModuleInfo) :-
+ merge_ho_inst_info(HOInstInfoA, HOInstInfoB, HOInstInfo, !ModuleInfo),
merge_uniq(UniqA, UniqB, Uniq).
inst_merge_4(abstract_inst(Name, ArgsA), abstract_inst(Name, ArgsB),
_, abstract_inst(Name, Args), !ModuleInfo) :-
@@ -1545,6 +1588,34 @@
Merged = UniqA
).
+:- pred merge_ho_inst_info(ho_inst_info::in, ho_inst_info::in,
+ ho_inst_info::out, module_info::in, module_info::out) is semidet.
+
+merge_ho_inst_info(HOInstInfoA, HOInstInfoB, HOInstInfo, !ModuleInfo) :-
+ (
+ HOInstInfoA = higher_order(PredA),
+ HOInstInfoB = higher_order(PredB)
+ ->
+ % If they specify matching pred insts, but one is more precise
+ % (specifies more info) than the other, then we want to choose
+ % the least precise one.
+ ( pred_inst_matches(PredA, PredB, !.ModuleInfo) ->
+ HOInstInfo = higher_order(PredB)
+ ; pred_inst_matches(PredB, PredA, !.ModuleInfo) ->
+ HOInstInfo = higher_order(PredA)
+ ;
+ % If either is a function inst with non-standard modes,
+ % don't allow the higher-order information to be lost.
+ \+ pred_inst_info_is_nonstandard_func_mode(!.ModuleInfo, PredA),
+ \+ pred_inst_info_is_nonstandard_func_mode(!.ModuleInfo, PredB),
+ HOInstInfo = none
+ )
+ ;
+ \+ ho_inst_info_is_nonstandard_func_mode(!.ModuleInfo, HOInstInfoA),
+ \+ ho_inst_info_is_nonstandard_func_mode(!.ModuleInfo, HOInstInfoB),
+ HOInstInfo = none
+ ).
+
% merge_uniq_bound(UniqA, UniqB, ListB, ModuleInfo, Uniq) succeeds iff
% Uniq is the result of merging
%
@@ -1581,7 +1652,7 @@
:- pred merge_inst_uniq(mer_inst::in, uniqueness::in, module_info::in,
set(inst_name)::in, set(inst_name)::out, uniqueness::out) is det.
-merge_inst_uniq(any(UniqA), UniqB, _, !Expansions, Uniq) :-
+merge_inst_uniq(any(UniqA, _), UniqB, _, !Expansions, Uniq) :-
merge_uniq(UniqA, UniqB, Uniq).
merge_inst_uniq(free, Uniq, _, !Expansions, Uniq).
merge_inst_uniq(free(_), Uniq, _, !Expansions, Uniq).
@@ -1634,7 +1705,7 @@
;
MaybeType = no,
merge_uniq_bound(UniqB, UniqA, ListA, !.ModuleInfo, Uniq),
- Result = any(Uniq)
+ Result = any(Uniq, none)
)
).
@@ -1697,9 +1768,9 @@
:- pred inst_contains_nonstandard_func_mode_2(module_info::in, mer_inst::in,
set(mer_inst)::in) is semidet.
-inst_contains_nonstandard_func_mode_2(ModuleInfo, ground(_, GroundInstInfo),
+inst_contains_nonstandard_func_mode_2(ModuleInfo, ground(_, HOInstInfo),
_Expansions) :-
- ground_inst_info_is_nonstandard_func_mode(ModuleInfo, GroundInstInfo).
+ ho_inst_info_is_nonstandard_func_mode(ModuleInfo, HOInstInfo).
inst_contains_nonstandard_func_mode_2(ModuleInfo, bound(_, BoundInsts),
Expansions) :-
list.member(bound_functor(_, Insts), BoundInsts),
@@ -1723,7 +1794,7 @@
:- pred inst_contains_any_2(module_info::in, (mer_inst)::in,
set(inst_name)::in) is semidet.
-inst_contains_any_2(_ModuleInfo, any(_), _Expansions).
+inst_contains_any_2(_ModuleInfo, any(_, _), _Expansions).
inst_contains_any_2(ModuleInfo, bound(_, BoundInsts), Expansions) :-
list.member(bound_functor(_, Insts), BoundInsts),
@@ -1753,8 +1824,8 @@
\+ pred_inst_matches(PredInstInfo,
pred_inst_info_standard_func_mode(Arity), ModuleInfo).
-ground_inst_info_is_nonstandard_func_mode(ModuleInfo, GroundInstInfo) :-
- GroundInstInfo = higher_order(PredInstInfo),
+ho_inst_info_is_nonstandard_func_mode(ModuleInfo, HOInstInfo) :-
+ HOInstInfo = higher_order(PredInstInfo),
pred_inst_info_is_nonstandard_func_mode(ModuleInfo, PredInstInfo).
pred_inst_info_standard_func_mode(Arity) =
@@ -1797,7 +1868,7 @@
inst_may_restrict_cons_ids(ModuleInfo, Inst) = MayRestrict :-
(
- Inst = any(_),
+ Inst = any(_, _),
MayRestrict = yes
;
Inst = free,
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.226
diff -u -r1.226 intermod.m
--- compiler/intermod.m 30 Dec 2007 08:23:44 -0000 1.226
+++ compiler/intermod.m 8 Jan 2008 10:29:35 -0000
@@ -712,9 +712,9 @@
RHS = RHS0,
DoWrite = yes
;
- RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, Goal0),
+ RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, H, Goal0),
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info),
- RHS = rhs_lambda_goal(A, B, C, D, E, F, G, Goal)
+ RHS = rhs_lambda_goal(A, B, C, D, E, F, G, H, Goal)
;
RHS0 = rhs_functor(Functor, _Exist, _Vars),
RHS = RHS0,
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.133
diff -u -r1.133 lambda.m
--- compiler/lambda.m 30 Dec 2007 08:23:45 -0000 1.133
+++ compiler/lambda.m 8 Jan 2008 10:29:35 -0000
@@ -284,15 +284,16 @@
lambda_process_unify_goal(LHS, RHS0, Mode, Unification0, Context, GoalExpr,
!Info) :-
(
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NonLocalVars, Vars, Modes, Det, LambdaGoal0),
% First, process the lambda goal recursively, in case it contains
% some nested lambda expressions.
lambda_process_goal(LambdaGoal0, LambdaGoal, !Info),
% Then, convert the lambda expression into a new predicate.
- lambda_process_lambda(Purity, PredOrFunc, EvalMethod, Vars, Modes, Det,
- NonLocalVars, LambdaGoal, Unification0, Y, Unification, !Info),
+ lambda_process_lambda(Purity, Groundness, PredOrFunc, EvalMethod, Vars,
+ Modes, Det, NonLocalVars, LambdaGoal, Unification0, Y, Unification,
+ !Info),
GoalExpr = unify(LHS, Y, Mode, Unification, Context)
;
( RHS0 = rhs_var(_)
@@ -302,15 +303,15 @@
GoalExpr = unify(LHS, RHS0, Mode, Unification0, Context)
).
-:- pred lambda_process_lambda(purity::in, pred_or_func::in,
- lambda_eval_method::in,
+:- pred lambda_process_lambda(purity::in, ho_groundness::in,
+ pred_or_func::in, lambda_eval_method::in,
list(prog_var)::in, list(mer_mode)::in, determinism::in,
list(prog_var)::in, hlds_goal::in, unification::in, unify_rhs::out,
unification::out, lambda_info::in, lambda_info::out) is det.
-lambda_process_lambda(Purity, PredOrFunc, EvalMethod, Vars, Modes, Detism,
- OrigNonLocals0, LambdaGoal, Unification0, Functor,
- Unification, LambdaInfo0, LambdaInfo) :-
+lambda_process_lambda(Purity, _Groundness, PredOrFunc, EvalMethod, Vars, Modes,
+ Detism, OrigNonLocals0, LambdaGoal, Unification0, Functor, Unification,
+ LambdaInfo0, LambdaInfo) :-
LambdaInfo0 = lambda_info(VarSet, VarTypes, TVarSet,
InstVarSet, RttiVarMaps, Markers, HasParallelConj, POF, OrigPredName,
ModuleInfo0, MustRecomputeNonLocals0),
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.49
diff -u -r1.49 lco.m
--- compiler/lco.m 30 Dec 2007 08:23:45 -0000 1.49
+++ compiler/lco.m 8 Jan 2008 10:29:35 -0000
@@ -745,7 +745,7 @@
rename_var_list(need_not_rename, Subst, RHSVars0, RHSVars),
RHS = rhs_functor(RHSConsId, IsExistConstr, RHSVars)
;
- RHS0 = rhs_lambda_goal(_, _, _, _, _, _, _, _),
+ RHS0 = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
unexpected(this_file, "update_construct: lambda RHS")
),
GoalExpr = unify(LHS, RHS, Mode, Unification, UnifyContext),
Index: compiler/loop_inv.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/loop_inv.m,v
retrieving revision 1.44
diff -u -r1.44 loop_inv.m
--- compiler/loop_inv.m 30 Dec 2007 08:23:48 -0000 1.44
+++ compiler/loop_inv.m 8 Jan 2008 10:29:35 -0000
@@ -1231,7 +1231,7 @@
UnifyRHS = rhs_functor(_, _, _),
Inputs = [LHS]
;
- UnifyRHS = rhs_lambda_goal(_, _, _, _, _, _, _, _),
+ UnifyRHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
% These should have been expanded out by now.
unexpected(this_file, "goal_expr_inputs: lambda goal")
)
Index: compiler/make_hlds_warn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_warn.m,v
retrieving revision 1.25
diff -u -r1.25 make_hlds_warn.m
--- compiler/make_hlds_warn.m 30 Dec 2007 08:23:48 -0000 1.25
+++ compiler/make_hlds_warn.m 8 Jan 2008 10:29:35 -0000
@@ -263,8 +263,8 @@
NonLocals = goal_info_get_nonlocals(GoalInfo),
warn_singletons_goal_vars([X | Vars], GoalInfo, NonLocals, QuantVars,
VarSet, CallPredId, !Specs).
-warn_singletons_in_unify(X, rhs_lambda_goal(_Purity, _PredOrFunc, _Eval,
- _NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
+warn_singletons_in_unify(X, rhs_lambda_goal(_Purity, _Groundness, _PredOrFunc,
+ _Eval, _NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
GoalInfo, QuantVars, VarSet, CallPredId, ModuleInfo, !Specs) :-
% Warn if any lambda-quantified variables occur only in the quantifier.
LambdaGoal = hlds_goal(_, LambdaGoalInfo),
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.323
diff -u -r1.323 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 5 Dec 2007 05:07:33 -0000 1.323
+++ compiler/mercury_to_mercury.m 8 Jan 2008 10:29:35 -0000
@@ -1145,9 +1145,15 @@
:- pred mercury_format_structured_inst(mer_inst::in, int::in, inst_varset::in,
U::di, U::uo) is det <= output(U).
-mercury_format_structured_inst(any(Uniq), Indent, _, !U) :-
+mercury_format_structured_inst(any(Uniq, HOInstInfo), Indent, VarSet, !U) :-
mercury_format_tabs(Indent, !U),
- mercury_format_any_uniqueness(Uniq, !U),
+ (
+ HOInstInfo = higher_order(PredInstInfo),
+ mercury_format_any_pred_inst_info(Uniq, PredInstInfo, VarSet, !U)
+ ;
+ HOInstInfo = none,
+ mercury_format_any_uniqueness(Uniq, !U)
+ ),
add_string("\n", !U).
mercury_format_structured_inst(free, Indent, _, !U) :-
mercury_format_tabs(Indent, !U),
@@ -1162,61 +1168,16 @@
mercury_format_structured_bound_insts(BoundInsts, Indent, VarSet, !U),
mercury_format_tabs(Indent, !U),
add_string(")\n", !U).
-mercury_format_structured_inst(ground(Uniq, GroundInstInfo), Indent, VarSet,
- !U) :-
+mercury_format_structured_inst(ground(Uniq, HOInstInfo), Indent, VarSet, !U) :-
mercury_format_tabs(Indent, !U),
(
- GroundInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)),
- (
- Uniq = shared
- ;
- ( Uniq = unique
- ; Uniq = mostly_unique
- ; Uniq = clobbered
- ; Uniq = mostly_clobbered
- ),
- add_string("/* ", !U),
- mercury_format_uniqueness(Uniq, "ground", !U),
- add_string(" */", !U)
- ),
- (
- PredOrFunc = pf_predicate,
- (
- Modes = [],
- add_string("((pred) is ", !U),
- mercury_format_det(Det, !U),
- add_string(")\n", !U)
- ;
- Modes = [_ | _],
- add_string("(pred(", !U),
- mercury_format_mode_list(Modes, simple_inst_info(VarSet), !U),
- add_string(") is ", !U),
- mercury_format_det(Det, !U),
- add_string(")\n", !U)
- )
- ;
- PredOrFunc = pf_function,
- pred_args_to_func_args(Modes, ArgModes, RetMode),
- (
- Modes = [],
- add_string("((func) = ", !U)
- ;
- Modes = [_ | _],
- add_string("(func(", !U),
- mercury_format_mode_list(ArgModes, simple_inst_info(VarSet),
- !U),
- add_string(") = ", !U)
- ),
- mercury_format_mode(RetMode, simple_inst_info(VarSet), !U),
- add_string(" is ", !U),
- mercury_format_det(Det, !U),
- add_string(")\n", !U)
- )
+ HOInstInfo = higher_order(PredInstInfo),
+ mercury_format_ground_pred_inst_info(Uniq, PredInstInfo, VarSet, !U)
;
- GroundInstInfo = none,
- mercury_format_uniqueness(Uniq, "ground", !U),
- add_string("\n", !U)
- ).
+ HOInstInfo = none,
+ mercury_format_uniqueness(Uniq, "ground", !U)
+ ),
+ add_string("\n", !U).
mercury_format_structured_inst(inst_var(Var), Indent, VarSet, !U) :-
mercury_format_tabs(Indent, !U),
mercury_format_var(VarSet, no, Var, !U),
@@ -1237,6 +1198,108 @@
mercury_format_tabs(Indent, !U),
add_string("not_reached\n", !U).
+:- pred mercury_format_ground_pred_inst_info(uniqueness::in,
+ pred_inst_info::in, inst_varset::in, U::di, U::uo) is det <= output(U).
+
+mercury_format_ground_pred_inst_info(Uniq, PredInstInfo, VarSet, !U) :-
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ (
+ Uniq = shared
+ ;
+ ( Uniq = unique
+ ; Uniq = mostly_unique
+ ; Uniq = clobbered
+ ; Uniq = mostly_clobbered
+ ),
+ add_string("/* ", !U),
+ mercury_format_uniqueness(Uniq, "ground", !U),
+ add_string(" */", !U)
+ ),
+ (
+ PredOrFunc = pf_predicate,
+ (
+ Modes = [],
+ add_string("((pred) is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ ;
+ Modes = [_ | _],
+ add_string("(pred(", !U),
+ mercury_format_mode_list(Modes, simple_inst_info(VarSet), !U),
+ add_string(") is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ )
+ ;
+ PredOrFunc = pf_function,
+ pred_args_to_func_args(Modes, ArgModes, RetMode),
+ (
+ ArgModes = [],
+ add_string("((func) = ", !U)
+ ;
+ ArgModes = [_ | _],
+ add_string("(func(", !U),
+ mercury_format_mode_list(ArgModes, simple_inst_info(VarSet),
+ !U),
+ add_string(") = ", !U)
+ ),
+ mercury_format_mode(RetMode, simple_inst_info(VarSet), !U),
+ add_string(" is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ ).
+
+:- pred mercury_format_any_pred_inst_info(uniqueness::in, pred_inst_info::in,
+ inst_varset::in, U::di, U::uo) is det <= output(U).
+
+mercury_format_any_pred_inst_info(Uniq, PredInstInfo, VarSet, !U) :-
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ (
+ Uniq = shared
+ ;
+ ( Uniq = unique
+ ; Uniq = mostly_unique
+ ; Uniq = clobbered
+ ; Uniq = mostly_clobbered
+ ),
+ add_string("/* ", !U),
+ mercury_format_uniqueness(Uniq, "any", !U),
+ add_string(" */", !U)
+ ),
+ (
+ PredOrFunc = pf_predicate,
+ (
+ Modes = [],
+ add_string("(any_pred is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ ;
+ Modes = [_ | _],
+ add_string("(any_pred(", !U),
+ mercury_format_mode_list(Modes, simple_inst_info(VarSet), !U),
+ add_string(") is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ )
+ ;
+ PredOrFunc = pf_function,
+ pred_args_to_func_args(Modes, ArgModes, RetMode),
+ (
+ Modes = [],
+ add_string("(any_func = ", !U)
+ ;
+ Modes = [_ | _],
+ add_string("(any_func(", !U),
+ mercury_format_mode_list(ArgModes, simple_inst_info(VarSet),
+ !U),
+ add_string(") = ", !U)
+ ),
+ mercury_format_mode(RetMode, simple_inst_info(VarSet), !U),
+ add_string(" is ", !U),
+ mercury_format_det(Det, !U),
+ add_string(")", !U)
+ ).
+
:- instance inst_info(simple_inst_info) where [
func(instvarset/1) is sii_varset,
pred(format_defined_inst/4) is mercury_format_inst_name
@@ -1248,8 +1311,15 @@
mercury_inst_to_string(Inst, VarSet) = String :-
mercury_format_inst(Inst, simple_inst_info(VarSet), "", String).
-mercury_format_inst(any(Uniq), _, !U) :-
- mercury_format_any_uniqueness(Uniq, !U).
+mercury_format_inst(any(Uniq, HOInstInfo), InstInfo, !U) :-
+ (
+ HOInstInfo = higher_order(PredInstInfo),
+ mercury_format_any_pred_inst_info(Uniq, PredInstInfo,
+ instvarset(InstInfo), !U)
+ ;
+ HOInstInfo = none,
+ mercury_format_any_uniqueness(Uniq, !U)
+ ).
mercury_format_inst(free, _, !U) :-
add_string("free", !U).
mercury_format_inst(free(_T), _, !U) :-
@@ -1259,56 +1329,13 @@
add_string("(", !U),
mercury_format_bound_insts(BoundInsts, InstInfo, !U),
add_string(")", !U).
-mercury_format_inst(ground(Uniq, GroundInstInfo), InstInfo, !U) :-
+mercury_format_inst(ground(Uniq, HOInstInfo), InstInfo, !U) :-
(
- GroundInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)),
- (
- Uniq = shared
- ;
- ( Uniq = unique
- ; Uniq = mostly_unique
- ; Uniq = clobbered
- ; Uniq = mostly_clobbered
- ),
- add_string("/* ", !U),
- mercury_format_uniqueness(Uniq, "ground", !U),
- add_string(" */", !U)
- ),
- (
- PredOrFunc = pf_predicate,
- (
- Modes = [],
- add_string("((pred) is ", !U),
- mercury_format_det(Det, !U),
- add_string(")", !U)
- ;
- Modes = [_ | _],
- add_string("(pred(", !U),
- mercury_format_mode_list(Modes, InstInfo, !U),
- add_string(") is ", !U),
- mercury_format_det(Det, !U),
- add_string(")", !U)
- )
- ;
- PredOrFunc = pf_function,
- pred_args_to_func_args(Modes, ArgModes, RetMode),
- (
- ArgModes = [],
- add_string("((func)", !U)
- ;
- ArgModes = [_ | _],
- add_string("(func(", !U),
- mercury_format_mode_list(ArgModes, InstInfo, !U),
- add_string(")", !U)
- ),
- add_string(" = ", !U),
- mercury_format_mode(RetMode, InstInfo, !U),
- add_string(" is ", !U),
- mercury_format_det(Det, !U),
- add_string(")", !U)
- )
+ HOInstInfo = higher_order(PredInstInfo),
+ mercury_format_ground_pred_inst_info(Uniq, PredInstInfo,
+ instvarset(InstInfo), !U)
;
- GroundInstInfo = none,
+ HOInstInfo = none,
mercury_format_uniqueness(Uniq, "ground", !U)
).
mercury_format_inst(inst_var(Var), InstInfo, !U) :-
Index: compiler/mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_constraints.m,v
retrieving revision 1.44
diff -u -r1.44 mode_constraints.m
--- compiler/mode_constraints.m 30 Dec 2007 08:23:50 -0000 1.44
+++ compiler/mode_constraints.m 8 Jan 2008 10:29:35 -0000
@@ -490,7 +490,7 @@
!.RHS = rhs_functor(_, _, Args),
Vars = Args.
number_robdd_variables_in_rhs(InstGraph, GoalPath, Vars, !RHS, !NRInfo) :-
- !.RHS = rhs_lambda_goal(_, _, _, LambdaNonLocals, LambdaVars, _, _,
+ !.RHS = rhs_lambda_goal(_, _, _, _, LambdaNonLocals, LambdaVars, _, _,
LambdaGoal0),
Vars = LambdaNonLocals,
VarTypes = !.NRInfo ^ vartypes,
@@ -960,7 +960,7 @@
Inst, Seen, Var, !Constraint, !MDI) :-
update_mc_info((pred(C::out, S0::in, S::out) is det :-
(
- ( Inst = any(_)
+ ( Inst = any(_, _)
; Inst = bound(_, _)
; Inst = ground(_, _)
)
@@ -1619,7 +1619,7 @@
).
unify_constraints(Var, GoalPath, RHS0, RHS, !Constraint, !GCInfo) :-
- RHS0 = rhs_lambda_goal(_, _, _, NonLocals, LambdaVars, Modes, _, Goal0),
+ RHS0 = rhs_lambda_goal(_, _, _, _, NonLocals, LambdaVars, Modes, _, Goal0),
InstGraph = !.GCInfo ^ inst_graph,
% Variable Var is made ground by this goal.
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.122
diff -u -r1.122 mode_errors.m
--- compiler/mode_errors.m 30 Dec 2007 08:23:50 -0000 1.122
+++ compiler/mode_errors.m 8 Jan 2008 10:29:35 -0000
@@ -138,11 +138,9 @@
% contained an inst any non-local, but was not inside a
% promise_purity scope.
- ; purity_error_lambda_should_be_impure(list(prog_var)).
- % A lambda term containing inst any non-locals should have been
- % declared impure, but hasn't been (executing such a lambda may
- % further constrain the inst any variables, thereby violating
- % referential transparency).
+ ; purity_error_lambda_should_be_any(list(prog_var)).
+ % A ground lambda term contains inst any non-locals, and is not
+ % marked impure.
:- type negated_context_desc
---> if_then_else
@@ -336,8 +334,8 @@
Spec = purity_error_should_be_in_promise_purity_scope_to_spec(NegCtxt,
ModeInfo, Var)
;
- ModeError = purity_error_lambda_should_be_impure(Vars),
- Spec = purity_error_lambda_should_be_impure_to_spec(ModeInfo, Vars)
+ ModeError = purity_error_lambda_should_be_any(Vars),
+ Spec = purity_error_lambda_should_be_any_to_spec(ModeInfo, Vars)
).
mode_warning_info_to_spec(!.ModeInfo, Warning) = Spec :-
@@ -1127,22 +1125,30 @@
%-----------------------------------------------------------------------------%
-:- func purity_error_lambda_should_be_impure_to_spec(mode_info, list(prog_var))
+:- func purity_error_lambda_should_be_any_to_spec(mode_info, list(prog_var))
= error_spec.
-purity_error_lambda_should_be_impure_to_spec(ModeInfo, Vars) = Spec :-
+purity_error_lambda_should_be_any_to_spec(ModeInfo, Vars) = Spec :-
Preamble = mode_info_context_preamble(ModeInfo),
mode_info_get_context(ModeInfo, Context),
mode_info_get_varset(ModeInfo, VarSet),
Pieces = [
- words("purity error: lambda should be impure because it"),
- words("contains the following non-local variables"),
- words("whose insts contain `any':"),
+ words("purity error: lambda is `ground' but contains the"),
+ words("following non-local variables whose insts contain `any':"),
words(mercury_vars_to_string(VarSet, no, Vars)),
suffix("."), nl
],
+ Always = always(Preamble ++ Pieces),
+ VerboseOnly = verbose_only([
+ words("Predicate expressions with inst `any' can be written"),
+ quote("any_pred(Args) is det :- ..."),
+ suffix("."),
+ words("Function expressions with inst `any' can be written"),
+ quote("any_func(Args) = Result is det :- ..."),
+ suffix(".")
+ ]),
Spec = error_spec(severity_error, phase_mode_check(report_in_any_mode),
- [simple_msg(Context, [always(Preamble ++ Pieces)])]).
+ [simple_msg(Context, [Always, VerboseOnly])]).
%-----------------------------------------------------------------------------%
Index: compiler/mode_ordering.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_ordering.m,v
retrieving revision 1.25
diff -u -r1.25 mode_ordering.m
--- compiler/mode_ordering.m 12 Nov 2007 03:52:43 -0000 1.25
+++ compiler/mode_ordering.m 8 Jan 2008 10:29:35 -0000
@@ -279,11 +279,11 @@
% Unification = construct(VarA, _ConsId, _ArgVars,
% _UniModes, _HowTo, _CellUniq, _MaybeRLExprId),
Unification = Unification0, % XXX
- RHS0 = rhs_lambda_goal(A, B, C, NonLocals, LambdaVars, Modes0,
- G, SubGoal0),
+ RHS0 = rhs_lambda_goal(A, B, C, D, NonLocals, LambdaVars, Modes0,
+ H, SubGoal0),
Modes = Modes0, % XXX
- RHS = rhs_lambda_goal(A, B, C, NonLocals, LambdaVars, Modes,
- G, SubGoal),
+ RHS = rhs_lambda_goal(A, B, C, D, NonLocals, LambdaVars, Modes,
+ H, SubGoal),
GoalPath = goal_info_get_goal_path(!.GoalInfo),
enter_lambda_goal(GoalPath, !MOI),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.202
diff -u -r1.202 mode_util.m
--- compiler/mode_util.m 30 Dec 2007 08:23:50 -0000 1.202
+++ compiler/mode_util.m 8 Jan 2008 10:29:35 -0000
@@ -349,7 +349,7 @@
).
get_single_arg_inst(free, _, _, free).
get_single_arg_inst(free(_Type), _, _, free). % XXX loses type info
-get_single_arg_inst(any(Uniq), _, _, any(Uniq)).
+get_single_arg_inst(any(Uniq, _), _, _, any(Uniq, none)).
get_single_arg_inst(abstract_inst(_, _), _, _, _) :-
unexpected(this_file,
"get_single_arg_inst: abstract insts not supported").
@@ -570,8 +570,33 @@
propagate_ctor_info(ModuleInfo, Type, Constructors, Inst0, Inst) :-
(
- Inst0 = any(_Uniq),
- Inst = Inst0 % XXX loses type info!
+ Inst0 = any(Uniq, none),
+ ( type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) ->
+ default_higher_order_func_inst(ModuleInfo, ArgTypes, PredInstInfo),
+ Inst = any(Uniq, higher_order(PredInstInfo))
+ ;
+ constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors,
+ BoundInsts0),
+ list.sort_and_remove_dups(BoundInsts0, BoundInsts),
+ Inst = bound(Uniq, BoundInsts)
+ )
+ ;
+ Inst0 = any(Uniq, higher_order(PredInstInfo0)),
+ PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, Det),
+ (
+ type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes),
+ list.same_length(ArgTypes, Modes0)
+ ->
+ propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes)
+ ;
+ % The inst is not a valid inst for the type, so leave it alone.
+ % This can only happen if the user has made a mistake. A mode
+ % error should hopefully be reported if anything tries to match
+ % with the inst.
+ Modes = Modes0
+ ),
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ Inst = any(Uniq, higher_order(PredInstInfo))
;
Inst0 = free,
% Inst = free(Type)
@@ -643,8 +668,32 @@
propagate_ctor_info_lazily(ModuleInfo, Subst, Type0, Inst0, Inst) :-
(
- Inst0 = any(_Uniq),
- Inst = Inst0 % XXX loses type info!
+ Inst0 = any(Uniq, none),
+ apply_type_subst(Type0, Subst, Type),
+ ( type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) ->
+ default_higher_order_func_inst(ModuleInfo, ArgTypes, PredInstInfo),
+ Inst = any(Uniq, higher_order(PredInstInfo))
+ ;
+ Inst = any(Uniq, none)
+ )
+ ;
+ Inst0 = any(Uniq, higher_order(PredInstInfo0)),
+ PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, Det),
+ apply_type_subst(Type0, Subst, Type),
+ (
+ type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes),
+ list.same_length(ArgTypes, Modes0)
+ ->
+ propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes)
+ ;
+ % The inst is not a valid inst for the type, so leave it alone.
+ % This can only happen if the user has made a mistake. A mode error
+ % should hopefully be reported if anything tries to match with the
+ % inst.
+ Modes = Modes0
+ ),
+ PredInstInfo = pred_inst_info(PredOrFunc, Modes, Det),
+ Inst = any(Uniq, higher_order(PredInstInfo))
;
Inst0 = free,
% Inst = free(Type0)
@@ -756,7 +805,7 @@
constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors, BoundInsts) :-
constructors_to_bound_insts_2(ModuleInfo, Uniq,
- Constructors, any(Uniq), BoundInsts).
+ Constructors, any(Uniq, none), BoundInsts).
:- pred constructors_to_bound_insts_2(module_info::in, uniqueness::in,
list(constructor)::in, mer_inst::in, list(bound_inst)::out) is det.
@@ -963,7 +1012,10 @@
(
RecomputeAtomic = no,
goal_is_atomic(GoalExpr0),
- GoalExpr0 \= unify(_, rhs_lambda_goal(_, _, _, _, _, _, _, _), _, _, _)
+ \+ (
+ GoalExpr0 = unify(_, RHS, _, _, _),
+ RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
+ )
% Lambda expressions always need to be processed.
->
GoalExpr = GoalExpr0,
@@ -1082,7 +1134,7 @@
GoalInfo, unify(LHS, RHS, UniMode, Uni, Context), VarTypes,
InstMap0, InstMapDelta, !RI) :-
(
- RHS0 = rhs_lambda_goal(Purity, PorF, EvalMethod, NonLocals,
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PorF, EvalMethod, NonLocals,
LambdaVars, Modes, Det, Goal0)
->
ModuleInfo0 = !.RI ^ module_info,
@@ -1090,7 +1142,7 @@
InstMap0, InstMap),
recompute_instmap_delta_1(Atomic, Goal0, Goal, VarTypes,
InstMap, _, !RI),
- RHS = rhs_lambda_goal(Purity, PorF, EvalMethod, NonLocals,
+ RHS = rhs_lambda_goal(Purity, Groundness, PorF, EvalMethod, NonLocals,
LambdaVars, Modes, Det, Goal)
;
RHS = RHS0
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.82
diff -u -r1.82 modecheck_call.m
--- compiler/modecheck_call.m 23 Nov 2007 07:35:16 -0000 1.82
+++ compiler/modecheck_call.m 8 Jan 2008 10:29:35 -0000
@@ -225,13 +225,17 @@
inst_expand(ModuleInfo0, PredVarInst0, PredVarInst),
list.length(Args0, Arity),
(
- PredVarInst = ground(_Uniq, GroundInstInfo),
(
- GroundInstInfo = higher_order(PredInstInfo)
+ PredVarInst = ground(_Uniq, HOInstInfo)
+ ;
+ PredVarInst = any(_Uniq, HOInstInfo)
+ ),
+ (
+ HOInstInfo = higher_order(PredInstInfo)
;
% If PredVar has no higher-order inst information, but is
% a function type, then assume the default function mode.
- GroundInstInfo = none,
+ HOInstInfo = none,
mode_info_get_var_types(!.ModeInfo, VarTypes),
map.lookup(VarTypes, PredVar, Type),
type_is_higher_order_details(Type, _, pf_function, _, ArgTypes),
@@ -241,17 +245,33 @@
PredInstInfo = pred_inst_info(PredOrFunc, ModesPrime, DetPrime),
list.length(ModesPrime, Arity)
->
- Det = DetPrime,
- Modes = ModesPrime,
- ArgOffset = 1,
- modecheck_arg_list(ArgOffset, Modes, ExtraGoals, Args0, Args,
- !ModeInfo),
-
- ( determinism_components(Det, _, at_most_zero) ->
- instmap.init_unreachable(Instmap),
- mode_info_set_instmap(Instmap, !ModeInfo)
+ (
+ % If PredVar is inst `any' then it gets bound. If it is locked,
+ % this is a mode error.
+ PredVarInst = any(A, B),
+ mode_info_var_is_locked(!.ModeInfo, PredVar, Reason)
+ ->
+ BetterPredVarInst = ground(A, B),
+ set.singleton_set(WaitingVars, PredVar),
+ mode_info_error(WaitingVars, mode_error_bind_var(Reason, PredVar,
+ PredVarInst, BetterPredVarInst), !ModeInfo),
+ Modes = [],
+ Det = detism_erroneous,
+ Args = Args0,
+ ExtraGoals = no_extra_goals
;
- true
+ Det = DetPrime,
+ Modes = ModesPrime,
+ ArgOffset = 1,
+ modecheck_arg_list(ArgOffset, Modes, ExtraGoals, Args0, Args,
+ !ModeInfo),
+
+ ( determinism_components(Det, _, at_most_zero) ->
+ instmap.init_unreachable(Instmap),
+ mode_info_set_instmap(Instmap, !ModeInfo)
+ ;
+ true
+ )
)
;
% The error occurred in argument 1, i.e. the pred term.
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.123
diff -u -r1.123 modecheck_unify.m
--- compiler/modecheck_unify.m 30 Dec 2007 08:23:50 -0000 1.123
+++ compiler/modecheck_unify.m 8 Jan 2008 10:29:35 -0000
@@ -87,17 +87,26 @@
% context with an inst any argument then it has an explicit `impure'
% annotation.
%
- % With lambdas, the lambda itself must be marked as impure if it includes
- % any inst any nonlocals (executing such a lambda may have the side effect
- % of constraining a nonlocal solver variable).
+ % With lambdas, the lambda itself has a higher-order any inst if it
+ % includes any inst any nonlocals. The value of the lambda expression
+ % does not become fixed until all of the non-locals become fixed.
+ % Executing such a lambda may constrain nonlocal solver variables,
+ % which in turn constrains the higher-order value itself. Effectively,
+ % call/N constrains the predicate value to be "some predicate that is
+ % true for the given arguments", and apply/N constrains the function
+ % value to be "some function that returns the given value for the given
+ % arguments".
+ %
+ % But we also allow a ground higher-order inst to be used with non-ground
+ % locals, provided the type of the higher-order value is impure.
%
modecheck_unification(X, RHS, Unification0, UnifyContext, UnifyGoalInfo0,
Unify, !ModeInfo, !IO) :-
(
- % If this is a lambda unification containing some inst any
+ % If this is a ground lambda unification containing some inst any
% nonlocals, then the lambda should be marked as impure.
%
- RHS = rhs_lambda_goal(Purity, _, _, NonLocals, _, _, _, _),
+ RHS = rhs_lambda_goal(Purity, ho_ground, _, _, NonLocals, _, _, _, _),
Purity \= purity_impure,
mode_info_get_module_info(!.ModeInfo, ModuleInfo),
mode_info_get_instmap(!.ModeInfo, InstMap),
@@ -107,7 +116,7 @@
->
set.init(WaitingVars),
mode_info_error(WaitingVars,
- purity_error_lambda_should_be_impure(AnyVars), !ModeInfo),
+ purity_error_lambda_should_be_any(AnyVars), !ModeInfo),
Unify = conj(plain_conj, [])
;
modecheck_unification_2(X, RHS, Unification0, UnifyContext,
@@ -263,20 +272,22 @@
modecheck_unification_2(X, LambdaGoal, Unification0, UnifyContext, _GoalInfo,
unify(X, RHS, Mode, Unification, UnifyContext), !ModeInfo, !IO) :-
- LambdaGoal = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ LambdaGoal = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
ArgVars, Vars, Modes0, Det, Goal0),
% First modecheck the lambda goal itself:
%
- % initialize the initial insts of the lambda variables,
- % check that the non-local vars are ground (XXX or any),
- % mark the non-local vars as shared,
- % lock the non-local vars,
- % mark the non-clobbered lambda variables as live,
- % modecheck the goal,
- % check that the final insts are correct,
- % unmark the live vars,
- % unlock the non-local vars,
+ % initialize the initial insts of the lambda variables;
+ % check that the non-local vars are ground or any;
+ % mark the non-local vars as shared;
+ % if the higher-order inst is ground lock the non-local vars,
+ % otherwise if it is `any' lock the non-local vars that themselves
+ % do not match_initial any;
+ % mark the non-clobbered lambda variables as live;
+ % modecheck the goal;
+ % check that the final insts are correct;
+ % unmark the live vars;
+ % unlock the locked vars;
% restore the original instmap.
%
% XXX or should we merge the original and the final instmaps???
@@ -327,12 +338,30 @@
set.list_to_set(LiveVarsList, LiveVars),
mode_info_add_live_vars(LiveVars, !ModeInfo),
- % Lock the non-locals. (A lambda goal is not allowed to bind any of the
- % non-local variables, since it could get called more than once, or
- % from inside a negation.)
+ % Lock the non-locals. A ground lambda goal is not allowed to bind any
+ % of the non-local variables, since it could get called more than once,
+ % or from inside a negation. So in this case we lock all non-locals
+ % (not counting the lambda quantified vars).
+ %
+ % If the lambda goal is inst `any', we don't lock the non-locals which
+ % match_initial any, since it is safe to bind these any time that it
+ % is safe to bind the lambda goal itself.
Goal0 = hlds_goal(_, GoalInfo0),
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
- set.delete_list(NonLocals0, Vars, NonLocals),
+ set.delete_list(NonLocals0, Vars, NonLocals1),
+ (
+ Groundness = ho_ground,
+ NonLocals = NonLocals1
+ ;
+ Groundness = ho_any,
+ mode_info_get_var_types(!.ModeInfo, NonLocalTypes),
+ NonLocals = set.filter((pred(NonLocal::in) is semidet :-
+ map.lookup(NonLocalTypes, NonLocal, NonLocalType),
+ instmap.lookup_var(InstMap1, NonLocal, NonLocalInst),
+ \+ inst_matches_initial(NonLocalInst, any(shared, none),
+ NonLocalType, ModuleInfo0)
+ ), NonLocals1)
+ ),
set.to_sorted_list(NonLocals, NonLocalsList),
instmap.lookup_vars(NonLocalsList, InstMap1, NonLocalInsts),
mode_info_get_module_info(!.ModeInfo, ModuleInfo2),
@@ -351,15 +380,14 @@
% we've mode-checked the lambda body. (See the above comment on
% merging the initial and final instmaps.)
- % XXX This test is also not conservative enough!
- %
- % We should not allow non-local vars to have inst `any'; because that
- % can lead to unsoundness. However, disallowing that idiom would break
- % extras/trailed_update/samples/vqueens.m, and would make freeze/3
- % basically useless... so for now at least, let's not disallow it,
- % even though it is unsafe.
-
- inst_list_is_ground_or_any(NonLocalInsts, ModuleInfo2)
+ (
+ Groundness = ho_ground,
+ Purity \= purity_impure
+ ->
+ inst_list_is_ground(NonLocalInsts, ModuleInfo2)
+ ;
+ inst_list_is_ground_or_any(NonLocalInsts, ModuleInfo2)
+ )
->
make_shared_inst_list(NonLocalInsts, SharedNonLocalInsts,
ModuleInfo2, ModuleInfo3),
@@ -397,8 +425,8 @@
% Now modecheck the unification of X with the lambda-expression.
- RHS0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, ArgVars,
- Vars, Modes, Det, Goal),
+ RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ ArgVars, Vars, Modes, Det, Goal),
modecheck_unify_lambda(X, PredOrFunc, ArgVars, Modes, Det,
RHS0, RHS, Unification0, Unification, Mode, !ModeInfo)
;
@@ -419,8 +447,8 @@
"modecheck_unification_2(lambda): very strange var")
),
% Return any old garbage.
- RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, ArgVars,
- Vars, Modes0, Det, Goal0),
+ RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ ArgVars, Vars, Modes0, Det, Goal0),
Mode = (free -> free) - (free -> free),
Unification = Unification0
).
@@ -1197,7 +1225,7 @@
proc(PredId, ProcId) =
unshroud_pred_proc_id(ShroudedPredProcId),
(
- RHS0 = rhs_lambda_goal(_, _, EvalMethod, _, _, _, _, Goal),
+ RHS0 = rhs_lambda_goal(_, _, _, EvalMethod, _, _, _, _, Goal),
Goal = hlds_goal(plain_call(PredId, ProcId, _, _, _, _), _)
->
module_info_pred_info(ModuleInfo, PredId, PredInfo),
@@ -1418,8 +1446,8 @@
get_mode_of_args(not_reached, ArgInsts, ArgModes) :-
mode_set_args(ArgInsts, not_reached, ArgModes).
-get_mode_of_args(any(Uniq), ArgInsts, ArgModes) :-
- mode_set_args(ArgInsts, any(Uniq), ArgModes).
+get_mode_of_args(any(Uniq, none), ArgInsts, ArgModes) :-
+ mode_set_args(ArgInsts, any(Uniq, none), ArgModes).
get_mode_of_args(ground(Uniq, none), ArgInsts, ArgModes) :-
mode_set_args(ArgInsts, ground(Uniq, none), ArgModes).
get_mode_of_args(bound(_Uniq, List), ArgInstsA, ArgModes) :-
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.365
diff -u -r1.365 modes.m
--- compiler/modes.m 30 Dec 2007 08:23:51 -0000 1.365
+++ compiler/modes.m 8 Jan 2008 10:29:35 -0000
@@ -2451,13 +2451,10 @@
candidate_init_vars_3(_ModeInfo, Goal, !NonFree, !CandidateVars) :-
% A var/lambda unification, which can only be deterministic if it is
- % a construction. The non-locals in the lambda are *not* candidates
- % for initialisation because that could permit violations of referential
- % transparency (executing the lambda could otherwise further constrain
- % a solver variable that was not supplied as an argument).
+ % a construction.
%
Goal = hlds_goal(unify(X, RHS, _, _, _), _),
- RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _),
+ RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
% If this is a construction then X must be free.
not set.member(X, !.NonFree),
@@ -3177,7 +3174,7 @@
% a partially instantiated deep copy, and we don't know how to do
% that yet.
- InitialInst = any(_),
+ InitialInst = any(_, _),
inst_is_free(ModuleInfo0, VarInst1)
->
% This is the simple case of implied `any' modes, where the declared
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.161
diff -u -r1.161 module_qual.m
--- compiler/module_qual.m 5 Dec 2007 05:07:34 -0000 1.161
+++ compiler/module_qual.m 8 Jan 2008 10:29:35 -0000
@@ -974,7 +974,8 @@
:- pred qualify_inst(mer_inst::in, mer_inst::out, mq_info::in, mq_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-qualify_inst(any(A), any(A), !Info, !Specs).
+qualify_inst(any(Uniq, HOInstInfo0), any(Uniq, HOInstInfo), !Info, !Specs) :-
+ qualify_ho_inst_info(HOInstInfo0, HOInstInfo, !Info, !Specs).
qualify_inst(free, free, !Info, !Specs).
qualify_inst(not_reached, not_reached, !Info, !Specs).
qualify_inst(free(_), _, !Info, !Specs) :-
@@ -982,16 +983,9 @@
qualify_inst(bound(Uniq, BoundInsts0), bound(Uniq, BoundInsts), !Info,
!Specs) :-
qualify_bound_inst_list(BoundInsts0, BoundInsts, !Info, !Specs).
-qualify_inst(ground(Uniq, GroundInstInfo0), ground(Uniq, GroundInstInfo),
+qualify_inst(ground(Uniq, HOInstInfo0), ground(Uniq, HOInstInfo),
!Info, !Specs) :-
- (
- GroundInstInfo0 = higher_order(pred_inst_info(A, Modes0, Det)),
- qualify_mode_list(Modes0, Modes, !Info, !Specs),
- GroundInstInfo = higher_order(pred_inst_info(A, Modes, Det))
- ;
- GroundInstInfo0 = none,
- GroundInstInfo = none
- ).
+ qualify_ho_inst_info(HOInstInfo0, HOInstInfo, !Info, !Specs).
qualify_inst(inst_var(Var), inst_var(Var), !Info, !Specs).
qualify_inst(constrained_inst_vars(Vars, Inst0),
constrained_inst_vars(Vars, Inst), !Info, !Specs) :-
@@ -1002,6 +996,20 @@
!Specs) :-
qualify_inst_list(Args0, Args, !Info, !Specs).
+:- pred qualify_ho_inst_info(ho_inst_info::in, ho_inst_info::out,
+ mq_info::in, mq_info::out, list(error_spec)::in, list(error_spec)::out)
+ is det.
+
+qualify_ho_inst_info(HOInstInfo0, HOInstInfo, !Info, !Specs) :-
+ (
+ HOInstInfo0 = higher_order(pred_inst_info(A, Modes0, Det)),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
+ HOInstInfo = higher_order(pred_inst_info(A, Modes, Det))
+ ;
+ HOInstInfo0 = none,
+ HOInstInfo = none
+ ).
+
% Find the unique inst_id that matches this inst, and qualify
% the argument insts.
%
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.65
diff -u -r1.65 pd_util.m
--- compiler/pd_util.m 30 Dec 2007 08:23:53 -0000 1.65
+++ compiler/pd_util.m 8 Jan 2008 10:29:35 -0000
@@ -833,7 +833,7 @@
:- pred inst_MSG_2(mer_inst::in, mer_inst::in, expansions::in, module_info::in,
mer_inst::out) is semidet.
-inst_MSG_2(any(_), any(Uniq), _, _, any(Uniq)).
+inst_MSG_2(any(_, _), any(UniqB, InfoB), _, _, any(UniqB, InfoB)).
inst_MSG_2(free, free, _M, _, free).
inst_MSG_2(bound(_, ListA), bound(UniqB, ListB), Expansions,
@@ -920,7 +920,7 @@
set(inst_name)::in, int::out) is det.
inst_size_2(_, not_reached, _, 0).
-inst_size_2(_, any(_), _, 0).
+inst_size_2(_, any(_, _), _, 0).
inst_size_2(_, free, _, 0).
inst_size_2(_, free(_), _, 0).
inst_size_2(_, ground(_, _), _, 0).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.324
diff -u -r1.324 polymorphism.m
--- compiler/polymorphism.m 30 Dec 2007 08:23:53 -0000 1.324
+++ compiler/polymorphism.m 8 Jan 2008 10:29:35 -0000
@@ -1171,8 +1171,8 @@
polymorphism_process_unify_functor(XVar, ConsId, Args, Mode,
Unification0, UnifyContext, GoalInfo0, Goal, !Info)
;
- Y = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, ArgVars0,
- LambdaVars, Modes, Det, LambdaGoal0),
+ Y = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ ArgVars0, LambdaVars, Modes, Det, LambdaGoal0),
% For lambda expressions, we must recursively traverse the lambda goal.
polymorphism_process_goal(LambdaGoal0, LambdaGoal1, !Info),
@@ -1183,8 +1183,8 @@
LambdaGoal1, LambdaGoal, NonLocalTypeInfos, !Info),
set.to_sorted_list(NonLocalTypeInfos, NonLocalTypeInfosList),
list.append(NonLocalTypeInfosList, ArgVars0, ArgVars),
- Y1 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, ArgVars,
- LambdaVars, Modes, Det, LambdaGoal),
+ Y1 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ ArgVars, LambdaVars, Modes, Det, LambdaGoal),
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
set.union(NonLocals0, NonLocalTypeInfos, NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
@@ -1418,8 +1418,10 @@
% Construct the lambda expression.
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- Functor = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, ArgVars0,
- LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
+ % Higher-order values created in this fashion are always ground.
+ Groundness = ho_ground,
+ Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
:- pred create_fresh_vars(list(mer_type)::in, list(prog_var)::out,
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.122
diff -u -r1.122 post_typecheck.m
--- compiler/post_typecheck.m 30 Dec 2007 08:23:54 -0000 1.122
+++ compiler/post_typecheck.m 8 Jan 2008 10:29:35 -0000
@@ -680,7 +680,7 @@
"in_interface_check_unify_rhs: type_to_ctor_and_args failed.")
)
;
- RHS = rhs_lambda_goal(_, _, _, _, _, _, _, Goal),
+ RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, Goal),
in_interface_check(ModuleInfo, PredInfo, Goal, !Specs)
).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.200
diff -u -r1.200 prog_data.m
--- compiler/prog_data.m 5 Dec 2007 05:07:36 -0000 1.200
+++ compiler/prog_data.m 8 Jan 2008 10:29:35 -0000
@@ -1401,16 +1401,19 @@
% This is how instantiatednesses and modes are represented.
%
:- type mer_inst
- ---> any(uniqueness)
- ; free
+ ---> free
; free(mer_type)
+ ; any(uniqueness, ho_inst_info)
+ % The ho_inst_info holds extra information
+ % about higher-order values.
+
; bound(uniqueness, list(bound_inst))
% The list(bound_inst) must be sorted.
- ; ground(uniqueness, ground_inst_info)
- % The ground_inst_info holds extra information
- % about the ground inst.
+ ; ground(uniqueness, ho_inst_info)
+ % The ho_inst_info holds extra information
+ % about higher-order values.
; not_reached
; inst_var(inst_var)
@@ -1443,19 +1446,33 @@
% on backtracking, so we will need to
% restore the old value on backtracking.
- % The ground_inst_info type gives extra information about ground insts.
+ % Was the lambda goal created with pred/func or any_pred/any_func?
+ %
+:- type ho_groundness
+ ---> ho_ground
+ ; ho_any.
+
+ % The ho_inst_info type gives extra information about `ground' and `any'
+ % insts relating to higher-order values.
%
-:- type ground_inst_info
+:- type ho_inst_info
---> higher_order(pred_inst_info)
- % The ground inst is higher-order.
+ % The inst is higher-order, and we have mode/determinism
+ % information for the value.
; none.
% No extra information is available.
% higher-order predicate terms are given the inst
- % `ground(shared, higher_order(PredInstInfo))'
+ % `ground(shared, higher_order(PredInstInfo))' or
+ % `any(shared, higher_order(PredInstInfo))'
% where the PredInstInfo contains the extra modes and the determinism
- % for the predicate. Note that the higher-order predicate term
- % itself must be ground.
+ % for the predicate. The higher-order predicate term itself cannot be
+ % free. If it contains non-local variables with inst `any' then it
+ % must be in the latter form, otherwise it may be in the former.
+ %
+ % Note that calling/applying a higher-order value that has the `any'
+ % inst may bind that variable further, hence these values cannot safely
+ % be called/applied in a negated context.
%
:- type pred_inst_info
---> pred_inst_info(
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.287
diff -u -r1.287 prog_io.m
--- compiler/prog_io.m 13 Dec 2007 08:44:48 -0000 1.287
+++ compiler/prog_io.m 8 Jan 2008 10:29:35 -0000
@@ -3444,7 +3444,12 @@
:- pred constrain_inst_vars_in_inst(inst_var_sub::in,
mer_inst::in, mer_inst::out) is det.
-constrain_inst_vars_in_inst(_, any(U), any(U)).
+constrain_inst_vars_in_inst(_, any(U, none), any(U, none)).
+constrain_inst_vars_in_inst(InstConstraints,
+ any(U, higher_order(PredInstInfo0)),
+ any(U, higher_order(PredInstInfo))) :-
+ constrain_inst_vars_in_pred_inst_info(InstConstraints, PredInstInfo0,
+ PredInstInfo).
constrain_inst_vars_in_inst(_, free, free).
constrain_inst_vars_in_inst(_, free(T), free(T)).
constrain_inst_vars_in_inst(InstConstraints, bound(U, BIs0), bound(U, BIs)) :-
@@ -3543,7 +3548,13 @@
:- pred inst_var_constraints_are_consistent_in_inst(mer_inst::in,
inst_var_sub::in, inst_var_sub::out) is semidet.
-inst_var_constraints_are_consistent_in_inst(any(_), !Sub).
+inst_var_constraints_are_consistent_in_inst(any(_, HOInstInfo), !Sub) :-
+ (
+ HOInstInfo = none
+ ;
+ HOInstInfo = higher_order(pred_inst_info(_, Modes, _)),
+ inst_var_constraints_are_consistent_in_modes(Modes, !Sub)
+ ).
inst_var_constraints_are_consistent_in_inst(free, !Sub).
inst_var_constraints_are_consistent_in_inst(free(_), !Sub).
inst_var_constraints_are_consistent_in_inst(bound(_, BoundInsts), !Sub) :-
@@ -3551,11 +3562,11 @@
(pred(bound_functor(_, Insts)::in, in, out) is semidet -->
inst_var_constraints_are_consistent_in_insts(Insts)),
BoundInsts, !Sub).
-inst_var_constraints_are_consistent_in_inst(ground(_, GroundInstInfo), !Sub) :-
+inst_var_constraints_are_consistent_in_inst(ground(_, HOInstInfo), !Sub) :-
(
- GroundInstInfo = none
+ HOInstInfo = none
;
- GroundInstInfo = higher_order(pred_inst_info(_, Modes, _)),
+ HOInstInfo = higher_order(pred_inst_info(_, Modes, _)),
inst_var_constraints_are_consistent_in_modes(Modes, !Sub)
).
inst_var_constraints_are_consistent_in_inst(not_reached, !Sub).
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 8 Jan 2008 10:29:35 -0000
@@ -43,8 +43,9 @@
% higher-order pred expression into a list of variables, a list
% of their corresponding modes, and a determinism.
%
-:- pred parse_pred_expression(term::in, lambda_eval_method::out,
- list(prog_term)::out, list(mer_mode)::out, determinism::out) is semidet.
+:- pred parse_pred_expression(term::in, ho_groundness::out,
+ lambda_eval_method::out, list(prog_term)::out, list(mer_mode)::out,
+ determinism::out) is semidet.
% parse_dcg_pred_expression/3 converts the first argument to a -->/2
% higher-order DCG pred expression into a list of arguments, a list
@@ -54,8 +55,11 @@
% `(pred(Var1::Mode1, ..., VarN::ModeN, DCG0Mode, DCGMode)
% is Det --> Goal)'.
%
-:- pred parse_dcg_pred_expression(term::in, lambda_eval_method::out,
- list(prog_term)::out, list(mer_mode)::out, determinism::out) is semidet.
+ % For `any' insts replace `pred' with `any_pred'.
+ %
+:- pred parse_dcg_pred_expression(term::in, ho_groundness::out,
+ lambda_eval_method::out, list(prog_term)::out, list(mer_mode)::out,
+ determinism::out) is semidet.
% parse_func_expression/3 converts the first argument to a :-/2
% higher-order func expression into a list of arguments, a list
@@ -74,8 +78,11 @@
% or
% `(func(Var1, ..., VarN) = (VarN1)). '
%
-:- pred parse_func_expression(term::in, lambda_eval_method::out,
- list(prog_term)::out, list(mer_mode)::out, determinism::out) is semidet.
+ % For `any' insts replace `func' with `any_func'.
+ %
+:- pred parse_func_expression(term::in, ho_groundness::out,
+ lambda_eval_method::out, list(prog_term)::out, list(mer_mode)::out,
+ determinism::out) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1062,29 +1069,51 @@
% Code for parsing pred/func expressions
%
-parse_pred_expression(PredTerm, lambda_normal, Args, Modes, Det) :-
+parse_pred_expression(PredTerm, Groundness, lambda_normal, Args, Modes, Det) :-
PredTerm = term.functor(term.atom("is"), [PredArgsTerm, DetTerm], _),
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Det),
- PredArgsTerm = term.functor(term.atom("pred"), PredArgsList, _),
+ PredArgsTerm = term.functor(term.atom(Name), PredArgsList, _),
+ (
+ Name = "pred",
+ Groundness = ho_ground
+ ;
+ Name = "any_pred",
+ Groundness = ho_any
+ ),
parse_pred_expr_args(PredArgsList, Args, Modes),
inst_var_constraints_are_consistent_in_modes(Modes).
-parse_dcg_pred_expression(PredTerm, lambda_normal, Args, Modes, Det) :-
+parse_dcg_pred_expression(PredTerm, Groundness, lambda_normal, Args, Modes,
+ Det) :-
PredTerm = term.functor(term.atom("is"), [PredArgsTerm, DetTerm], _),
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Det),
- PredArgsTerm = term.functor(term.atom("pred"), PredArgsList, _),
+ PredArgsTerm = term.functor(term.atom(Name), PredArgsList, _),
+ (
+ Name = "pred",
+ Groundness = ho_ground
+ ;
+ Name = "any_pred",
+ Groundness = ho_any
+ ),
parse_dcg_pred_expr_args(PredArgsList, Args, Modes),
inst_var_constraints_are_consistent_in_modes(Modes).
-parse_func_expression(FuncTerm, lambda_normal, Args, Modes, Det) :-
+parse_func_expression(FuncTerm, Groundness, lambda_normal, Args, Modes, Det) :-
% Parse a func expression with specified modes and determinism.
FuncTerm = term.functor(term.atom("is"), [EqTerm, DetTerm], _),
EqTerm = term.functor(term.atom("="), [FuncArgsTerm, RetTerm], _),
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Det),
- FuncArgsTerm = term.functor(term.atom("func"), FuncArgsList, _),
+ FuncArgsTerm = term.functor(term.atom(Name), FuncArgsList, _),
+ (
+ Name = "func",
+ Groundness = ho_ground
+ ;
+ Name = "any_func",
+ Groundness = ho_any
+ ),
( parse_pred_expr_args(FuncArgsList, Args0, Modes0) ->
parse_lambda_arg(RetTerm, RetArg, RetMode),
@@ -1104,10 +1133,17 @@
list.map(term.coerce, Args1, Args)
).
-parse_func_expression(FuncTerm, lambda_normal, Args, Modes, Det) :-
+parse_func_expression(FuncTerm, Groundness, lambda_normal, Args, Modes, Det) :-
% Parse a func expression with unspecified modes and determinism.
FuncTerm = term.functor(term.atom("="), [FuncArgsTerm, RetTerm], _),
- FuncArgsTerm = term.functor(term.atom("func"), Args0, _),
+ FuncArgsTerm = term.functor(term.atom(Name), Args0, _),
+ (
+ Name = "func",
+ Groundness = ho_ground
+ ;
+ Name = "any_func",
+ Groundness = ho_any
+ ),
% The argument modes default to `in', the return mode defaults to `out',
% and the determinism defaults to `det'.
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.57
diff -u -r1.57 prog_io_util.m
--- compiler/prog_io_util.m 19 Jan 2007 07:04:28 -0000 1.57
+++ compiler/prog_io_util.m 8 Jan 2008 10:29:35 -0000
@@ -507,6 +507,45 @@
Inst = ground(shared, higher_order(FuncInstInfo)),
Mode = (Inst -> Inst)
;
+ % Handle higher-order predicate modes:
+ % a mode of the form
+ % any_pred(<Mode1>, <Mode2>, ...) is <Det>
+ % is an abbreviation for the inst mapping
+ % ( any_pred(<Mode1>, <Mode2>, ...) is <Det>
+ % -> any_pred(<Mode1>, <Mode2>, ...) is <Det>
+ % )
+
+ Term = term.functor(term.atom("is"), [PredTerm, DetTerm], _),
+ PredTerm = term.functor(term.atom("any_pred"), ArgModesTerms, _)
+ ->
+ DetTerm = term.functor(term.atom(DetString), [], _),
+ standard_det(DetString, Detism),
+ convert_mode_list(AllowConstrainedInstVar, ArgModesTerms, ArgModes),
+ PredInstInfo = pred_inst_info(pf_predicate, ArgModes, Detism),
+ Inst = any(shared, higher_order(PredInstInfo)),
+ Mode = (Inst -> Inst)
+ ;
+ % Handle higher-order function modes:
+ % a mode of the form
+ % any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
+ % is an abbreviation for the inst mapping
+ % ( any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
+ % -> any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
+ % )
+
+ Term = term.functor(term.atom("is"), [EqTerm, DetTerm], _),
+ EqTerm = term.functor(term.atom("="), [FuncTerm, RetModeTerm], _),
+ FuncTerm = term.functor(term.atom("any_func"), ArgModesTerms, _)
+ ->
+ DetTerm = term.functor(term.atom(DetString), [], _),
+ standard_det(DetString, Detism),
+ convert_mode_list(AllowConstrainedInstVar, ArgModesTerms, ArgModes0),
+ convert_mode(AllowConstrainedInstVar, RetModeTerm, RetMode),
+ list.append(ArgModes0, [RetMode], ArgModes),
+ FuncInstInfo = pred_inst_info(pf_function, ArgModes, Detism),
+ Inst = any(shared, higher_order(FuncInstInfo)),
+ Mode = (Inst -> Inst)
+ ;
parse_qualified_term(Term, Term, "mode definition", R),
R = ok2(Name, Args), % should improve error reporting
convert_inst_list(AllowConstrainedInstVar, Args, ConvertedArgs),
@@ -527,7 +566,7 @@
->
Result = Result0
;
- % The syntax for a higher-order pred inst is
+ % The syntax for a ground higher-order pred inst is
%
% pred(<Mode1>, <Mode2>, ...) is <Detism>
%
@@ -543,7 +582,7 @@
PredInst = pred_inst_info(pf_predicate, ArgModes, Detism),
Result = ground(shared, higher_order(PredInst))
;
- % The syntax for a higher-order func inst is
+ % The syntax for a ground higher-order func inst is
%
% func(<Mode1>, <Mode2>, ...) = <RetMode> is <Detism>
%
@@ -561,6 +600,41 @@
list.append(ArgModes0, [RetMode], ArgModes),
FuncInst = pred_inst_info(pf_function, ArgModes, Detism),
Result = ground(shared, higher_order(FuncInst))
+ ;
+ % The syntax for an `any' higher-order pred inst is
+ %
+ % any_pred(<Mode1>, <Mode2>, ...) is <Detism>
+ %
+ % where <Mode1>, <Mode2>, ... are a list of modes,
+ % and <Detism> is a determinism.
+
+ Name = "is", Args0 = [PredTerm, DetTerm],
+ PredTerm = term.functor(term.atom("any_pred"), ArgModesTerm, _)
+ ->
+ DetTerm = term.functor(term.atom(DetString), [], _),
+ standard_det(DetString, Detism),
+ convert_mode_list(AllowConstrainedInstVar, ArgModesTerm, ArgModes),
+ PredInst = pred_inst_info(pf_predicate, ArgModes, Detism),
+ Result = any(shared, higher_order(PredInst))
+ ;
+ % The syntax for an `any' higher-order func inst is
+ %
+ % any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Detism>
+ %
+ % where <Mode1>, <Mode2>, ... are a list of modes,
+ % <RetMode> is a mode, and <Detism> is a determinism.
+
+ Name = "is", Args0 = [EqTerm, DetTerm],
+ EqTerm = term.functor(term.atom("="), [FuncTerm, RetModeTerm], _),
+ FuncTerm = term.functor(term.atom("any_func"), ArgModesTerm, _)
+ ->
+ DetTerm = term.functor(term.atom(DetString), [], _),
+ standard_det(DetString, Detism),
+ convert_mode_list(AllowConstrainedInstVar, ArgModesTerm, ArgModes0),
+ convert_mode(AllowConstrainedInstVar, RetModeTerm, RetMode),
+ list.append(ArgModes0, [RetMode], ArgModes),
+ FuncInst = pred_inst_info(pf_function, ArgModes, Detism),
+ Result = any(shared, higher_order(FuncInst))
; Name = "bound", Args0 = [Disj] ->
% `bound' insts
@@ -620,11 +694,12 @@
convert_simple_builtin_inst_2("free", free).
% `any' insts
-convert_simple_builtin_inst_2("any", any(shared)).
-convert_simple_builtin_inst_2("unique_any", any(unique)).
-convert_simple_builtin_inst_2("mostly_unique_any", any(mostly_unique)).
-convert_simple_builtin_inst_2("clobbered_any", any(clobbered)).
-convert_simple_builtin_inst_2("mostly_clobbered_any", any(mostly_clobbered)).
+convert_simple_builtin_inst_2("any", any(shared, none)).
+convert_simple_builtin_inst_2("unique_any", any(unique, none)).
+convert_simple_builtin_inst_2("mostly_unique_any", any(mostly_unique, none)).
+convert_simple_builtin_inst_2("clobbered_any", any(clobbered, none)).
+convert_simple_builtin_inst_2("mostly_clobbered_any",
+ any(mostly_clobbered, none)).
% `ground' insts
convert_simple_builtin_inst_2("ground", ground(shared, none)).
Index: compiler/prog_mode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mode.m,v
retrieving revision 1.20
diff -u -r1.20 prog_mode.m
--- compiler/prog_mode.m 1 Dec 2006 15:04:17 -0000 1.20
+++ compiler/prog_mode.m 8 Jan 2008 10:29:35 -0000
@@ -157,7 +157,7 @@
ground_inst = ground(shared, none).
free_inst = free.
-any_inst = any(shared).
+any_inst = any(shared, none).
make_std_mode(Name, Args, make_std_mode(Name, Args)).
@@ -266,11 +266,14 @@
:- pred inst_apply_substitution(inst_var_sub::in, mer_inst::in, mer_inst::out)
is det.
-inst_apply_substitution(_, any(Uniq), any(Uniq)).
+inst_apply_substitution(Subst, any(Uniq, HOInstInfo0), Inst) :-
+ ho_inst_info_apply_substitution(Subst, HOInstInfo0, HOInstInfo),
+ Inst = any(Uniq, HOInstInfo).
inst_apply_substitution(_, free, free).
inst_apply_substitution(_, free(T), free(T)).
-inst_apply_substitution(Subst, ground(Uniq, GroundInstInfo0), Inst) :-
- ground_inst_info_apply_substitution(Subst, Uniq, GroundInstInfo0, Inst).
+inst_apply_substitution(Subst, ground(Uniq, HOInstInfo0), Inst) :-
+ ho_inst_info_apply_substitution(Subst, HOInstInfo0, HOInstInfo),
+ Inst = ground(Uniq, HOInstInfo).
inst_apply_substitution(Subst, bound(Uniq, Alts0), bound(Uniq, Alts)) :-
alt_list_apply_substitution(Subst, Alts0, Alts).
inst_apply_substitution(_, not_reached, not_reached).
@@ -332,14 +335,14 @@
Alt = bound_functor(Name, Args),
alt_list_apply_substitution(Subst, Alts0, Alts).
-:- pred ground_inst_info_apply_substitution(inst_var_sub::in, uniqueness::in,
- ground_inst_info::in, mer_inst::out) is det.
+:- pred ho_inst_info_apply_substitution(inst_var_sub::in,
+ ho_inst_info::in, ho_inst_info::out) is det.
-ground_inst_info_apply_substitution(_, Uniq, none, ground(Uniq, none)).
-ground_inst_info_apply_substitution(Subst, Uniq, GII0, ground(Uniq, GII)) :-
- GII0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)),
+ho_inst_info_apply_substitution(_, none, none).
+ho_inst_info_apply_substitution(Subst, HOInstInfo0, HOInstInfo) :-
+ HOInstInfo0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)),
mode_list_apply_substitution(Subst, Modes0, Modes),
- GII = higher_order(pred_inst_info(PredOrFunc, Modes, Det)).
+ HOInstInfo = higher_order(pred_inst_info(PredOrFunc, Modes, Det)).
mode_list_apply_substitution(Subst, Modes0, Modes) :-
( map.is_empty(Subst) ->
@@ -375,7 +378,16 @@
:- pred rename_apart_inst_vars_in_inst(substitution(inst_var_type)::in,
mer_inst::in, mer_inst::out) is det.
-rename_apart_inst_vars_in_inst(_, any(U), any(U)).
+rename_apart_inst_vars_in_inst(Sub, any(Uniq, HOInstInfo0),
+ any(Uniq, HOInstInfo)) :-
+ (
+ HOInstInfo0 = higher_order(pred_inst_info(PorF, Modes0, Det)),
+ list.map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes),
+ HOInstInfo = higher_order(pred_inst_info(PorF, Modes, Det))
+ ;
+ HOInstInfo0 = none,
+ HOInstInfo = none
+ ).
rename_apart_inst_vars_in_inst(_, free, free).
rename_apart_inst_vars_in_inst(_, free(T), free(T)).
rename_apart_inst_vars_in_inst(Sub, bound(U, BIs0), bound(U, BIs)) :-
@@ -383,14 +395,15 @@
(pred(bound_functor(C, Is0)::in, bound_functor(C, Is)::out) is det :-
list.map(rename_apart_inst_vars_in_inst(Sub), Is0, Is)),
BIs0, BIs).
-rename_apart_inst_vars_in_inst(Sub, ground(U, GI0), ground(U, GI)) :-
+rename_apart_inst_vars_in_inst(Sub, ground(Uniq, HOInstInfo0),
+ ground(Uniq, HOInstInfo)) :-
(
- GI0 = higher_order(pred_inst_info(PoF, Modes0, Det)),
+ HOInstInfo0 = higher_order(pred_inst_info(PorF, Modes0, Det)),
list.map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes),
- GI = higher_order(pred_inst_info(PoF, Modes, Det))
+ HOInstInfo = higher_order(pred_inst_info(PorF, Modes, Det))
;
- GI0 = none,
- GI = none
+ HOInstInfo0 = none,
+ HOInstInfo = none
).
rename_apart_inst_vars_in_inst(_, not_reached, not_reached).
rename_apart_inst_vars_in_inst(Sub, inst_var(Var0), inst_var(Var)) :-
@@ -511,8 +524,8 @@
list.duplicate(Arity, free, ArgInsts).
get_arg_insts(free(_Type), _ConsId, Arity, ArgInsts) :-
list.duplicate(Arity, free, ArgInsts).
-get_arg_insts(any(Uniq), _ConsId, Arity, ArgInsts) :-
- list.duplicate(Arity, any(Uniq), ArgInsts).
+get_arg_insts(any(Uniq, _), _ConsId, Arity, ArgInsts) :-
+ list.duplicate(Arity, any(Uniq, none), ArgInsts).
:- pred get_arg_insts_2(list(bound_inst)::in, cons_id::in, list(mer_inst)::out)
is semidet.
@@ -576,9 +589,12 @@
strip_builtin_qualifiers_from_inst(not_reached, not_reached).
strip_builtin_qualifiers_from_inst(free, free).
strip_builtin_qualifiers_from_inst(free(Type), free(Type)).
-strip_builtin_qualifiers_from_inst(any(Uniq), any(Uniq)).
-strip_builtin_qualifiers_from_inst(ground(Uniq, GII0), ground(Uniq, GII)) :-
- strip_builtin_qualifiers_from_ground_inst_info(GII0, GII).
+strip_builtin_qualifiers_from_inst(any(Uniq, HOInstInfo0),
+ any(Uniq, HOInstInfo)) :-
+ strip_builtin_qualifiers_from_ho_inst_info(HOInstInfo0, HOInstInfo).
+strip_builtin_qualifiers_from_inst(ground(Uniq, HOInstInfo0),
+ ground(Uniq, HOInstInfo)) :-
+ strip_builtin_qualifiers_from_ho_inst_info(HOInstInfo0, HOInstInfo).
strip_builtin_qualifiers_from_inst(bound(Uniq, BoundInsts0),
bound(Uniq, BoundInsts)) :-
strip_builtin_qualifiers_from_bound_inst_list(BoundInsts0, BoundInsts).
@@ -639,11 +655,11 @@
typed_inst(Type, InstName)) :-
strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-:- pred strip_builtin_qualifiers_from_ground_inst_info(ground_inst_info::in,
- ground_inst_info::out) is det.
+:- pred strip_builtin_qualifiers_from_ho_inst_info(ho_inst_info::in,
+ ho_inst_info::out) is det.
-strip_builtin_qualifiers_from_ground_inst_info(none, none).
-strip_builtin_qualifiers_from_ground_inst_info(higher_order(Pred0),
+strip_builtin_qualifiers_from_ho_inst_info(none, none).
+strip_builtin_qualifiers_from_ho_inst_info(higher_order(Pred0),
higher_order(Pred)) :-
Pred0 = pred_inst_info(PorF, Modes0, Det),
Pred = pred_inst_info(PorF, Modes, Det),
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.116
diff -u -r1.116 purity.m
--- compiler/purity.m 30 Dec 2007 08:23:54 -0000 1.116
+++ compiler/purity.m 8 Jan 2008 10:29:35 -0000
@@ -527,11 +527,11 @@
ContainsTrace, !Info) :-
Unif0 = unify(Var, RHS0, Mode, Unification, UnifyContext),
(
- RHS0 = rhs_lambda_goal(LambdaPurity, F, EvalMethod, H, Vars,
- Modes, K, hlds_goal(LambdaGoalExpr0, LambdaGoalInfo0)),
+ RHS0 = rhs_lambda_goal(LambdaPurity, Groundness, F, EvalMethod, H,
+ Vars, Modes, K, hlds_goal(LambdaGoalExpr0, LambdaGoalInfo0)),
compute_expr_purity(LambdaGoalExpr0, LambdaGoalExpr, LambdaGoalInfo0,
GoalPurity, _, !Info),
- RHS = rhs_lambda_goal(LambdaPurity, F, EvalMethod, H, Vars,
+ RHS = rhs_lambda_goal(LambdaPurity, Groundness, F, EvalMethod, H, Vars,
Modes, K, hlds_goal(LambdaGoalExpr, LambdaGoalInfo0)),
check_closure_purity(GoalInfo, LambdaPurity, GoalPurity, !Info),
GoalExpr = unify(Var, RHS, Mode, Unification, UnifyContext),
Index: compiler/qual_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/qual_info.m,v
retrieving revision 1.22
diff -u -r1.22 qual_info.m
--- compiler/qual_info.m 7 Aug 2007 07:10:03 -0000 1.22
+++ compiler/qual_info.m 8 Jan 2008 10:29:35 -0000
@@ -250,7 +250,7 @@
(
Rhs = rhs_var(_)
;
- Rhs = rhs_lambda_goal(_, _, _, _, _, _, _, _)
+ Rhs = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
;
Rhs = rhs_functor(ConsId, _, _),
record_used_functor(ConsId, !QualInfo)
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.123
diff -u -r1.123 quantification.m
--- compiler/quantification.m 30 Dec 2007 08:23:55 -0000 1.123
+++ compiler/quantification.m 8 Jan 2008 10:29:35 -0000
@@ -733,7 +733,7 @@
),
set_nonlocals(Vars, !Info).
implicitly_quantify_unify_rhs(_, GoalInfo0, !RHS, !Unification, !Info) :-
- !.RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ !.RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
LambdaNonLocals0, LambdaVars0, Modes, Det, Goal0),
% Note: make_hlds.m has already done most of the hard work for
@@ -780,7 +780,7 @@
set_lambda_outside(LambdaOutsideVars, !Info),
implicitly_quantify_goal_quant_info(Goal1, Goal, !Info),
- !:RHS = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ !:RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
LambdaNonLocals, LambdaVars, Modes, Det, Goal),
get_nonlocals(!.Info, NonLocals0),
@@ -1306,7 +1306,7 @@
insert_list(!.Set, ArgVars, !:Set)
).
unify_rhs_vars(NonLocalsToRecompute,
- rhs_lambda_goal(_, _, _, _, LambdaVars, _, _, Goal), _,
+ rhs_lambda_goal(_, _, _, _, _, LambdaVars, _, _, Goal), _,
!Set, !LambdaSet) :-
% Note that the NonLocals list is not counted, since all the
% variables in that list must occur in the goal.
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.46
diff -u -r1.46 recompilation.usage.m
--- compiler/recompilation.usage.m 30 Dec 2007 08:23:56 -0000 1.46
+++ compiler/recompilation.usage.m 8 Jan 2008 10:29:35 -0000
@@ -1320,17 +1320,23 @@
:- pred find_items_used_by_inst(mer_inst::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
-find_items_used_by_inst(any(_), !Info).
+find_items_used_by_inst(any(_, HOInstInfo), !Info) :-
+ (
+ HOInstInfo = higher_order(pred_inst_info(_, Modes, _)),
+ find_items_used_by_modes(Modes, !Info)
+ ;
+ HOInstInfo = none
+ ).
find_items_used_by_inst(free, !Info).
find_items_used_by_inst(free(_), !Info).
find_items_used_by_inst(bound(_, BoundInsts), !Info) :-
list.foldl(find_items_used_by_bound_inst, BoundInsts, !Info).
-find_items_used_by_inst(ground(_, GroundInstInfo), !Info) :-
+find_items_used_by_inst(ground(_, HOInstInfo), !Info) :-
(
- GroundInstInfo = higher_order(pred_inst_info(_, Modes, _)),
+ HOInstInfo = higher_order(pred_inst_info(_, Modes, _)),
find_items_used_by_modes(Modes, !Info)
;
- GroundInstInfo = none
+ HOInstInfo = none
).
find_items_used_by_inst(not_reached, !Info).
find_items_used_by_inst(inst_var(_), !Info).
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.222
diff -u -r1.222 simplify.m
--- compiler/simplify.m 30 Dec 2007 08:23:56 -0000 1.222
+++ compiler/simplify.m 8 Jan 2008 10:29:35 -0000
@@ -1205,8 +1205,8 @@
simplify_goal_2_unify(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, !Info, !IO) :-
GoalExpr0 = unify(LT0, RT0, M, U0, C),
(
- RT0 = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocals,
- Vars, Modes, LambdaDeclaredDet, LambdaGoal0),
+ RT0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocals, Vars, Modes, LambdaDeclaredDet, LambdaGoal0),
simplify_info_enter_lambda(!Info),
simplify_info_get_common_info(!.Info, Common1),
simplify_info_get_module_info(!.Info, ModuleInfo),
@@ -1223,8 +1223,8 @@
simplify_goal(LambdaGoal0, LambdaGoal, !Info, !IO),
simplify_info_set_common_info(Common1, !Info),
simplify_info_set_instmap(InstMap1, !Info),
- RT = rhs_lambda_goal(Purity, PredOrFunc, EvalMethod, NonLocals,
- Vars, Modes, LambdaDeclaredDet, LambdaGoal),
+ RT = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
+ NonLocals, Vars, Modes, LambdaDeclaredDet, LambdaGoal),
simplify_info_leave_lambda(!Info),
GoalExpr = unify(LT0, RT, M, U0, C),
GoalInfo = GoalInfo0
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.64
diff -u -r1.64 stratify.m
--- compiler/stratify.m 30 Dec 2007 08:23:57 -0000 1.64
+++ compiler/stratify.m 8 Jan 2008 10:29:35 -0000
@@ -714,8 +714,9 @@
% Currently this code assumes that all procs called in a lambda goal
% have addresses taken. This is not always to case, but should be
% a suitable approximation for the stratification analysis.
- RHS = rhs_lambda_goal(_Purity, _PredOrFunc, _EvalMethod, _NonLocals,
- _Vars, _Modes, _Determinism, hlds_goal(GoalExpr, _GoalInfo))
+ RHS = rhs_lambda_goal(_Purity, _Groundness, _PredOrFunc, _EvalMethod,
+ _NonLocals, _Vars, _Modes, _Determinism,
+ hlds_goal(GoalExpr, _GoalInfo))
->
get_called_procs(GoalExpr, [], CalledProcs),
set.insert_list(!.HasAT, CalledProcs, !:HasAT)
@@ -796,8 +797,9 @@
% Currently this code assumes that all procs called in a lambda goal
% have addresses taken. This is not always to case, but should be
% a suitable approximation for the stratification analysis.
- RHS = rhs_lambda_goal(_Purity, _PredOrFunc, _EvalMethod, _NonLocals,
- _Vars, _Modes, _Determinism, hlds_goal(GoalExpr, _GoalInfo))
+ RHS = rhs_lambda_goal(_Purity, _Groundness, _PredOrFunc, _EvalMethod,
+ _NonLocals, _Vars, _Modes, _Determinism,
+ hlds_goal(GoalExpr, _GoalInfo))
->
get_called_procs(GoalExpr, !Calls)
;
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.26
diff -u -r1.26 superhomogeneous.m
--- compiler/superhomogeneous.m 19 Jan 2007 07:04:31 -0000 1.26
+++ compiler/superhomogeneous.m 8 Jan 2008 10:29:35 -0000
@@ -554,14 +554,19 @@
parse_rule_term(Context, RHS, HeadTerm0, GoalTerm1),
term.coerce(HeadTerm0, HeadTerm1),
parse_purity_annotation(HeadTerm1, LambdaPurity, HeadTerm),
- ( parse_pred_expression(HeadTerm, EvalMethod0, Vars0, Modes0, Det0) ->
+ (
+ parse_pred_expression(HeadTerm, Groundness0, EvalMethod0, Vars0,
+ Modes0, Det0)
+ ->
PredOrFunc = pf_predicate,
EvalMethod = EvalMethod0,
+ Groundness = Groundness0,
Vars1 = Vars0,
Modes1 = Modes0,
Det1 = Det0
;
- parse_func_expression(HeadTerm, EvalMethod, Vars1, Modes1, Det1),
+ parse_func_expression(HeadTerm, Groundness, EvalMethod, Vars1,
+ Modes1, Det1),
PredOrFunc = pf_function
)
->
@@ -572,8 +577,8 @@
parse_goal(GoalTerm, MaybeParsedGoal, !VarSet),
(
MaybeParsedGoal = ok1(ParsedGoal),
- build_lambda_expression(X, Purity, LambdaPurity, PredOrFunc,
- EvalMethod, Vars1, Modes, Det, ParsedGoal,
+ build_lambda_expression(X, Purity, LambdaPurity, Groundness,
+ PredOrFunc, EvalMethod, Vars1, Modes, Det, ParsedGoal,
Context, MainContext, SubContext, Goal, NumAdded,
!VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs)
;
@@ -592,7 +597,8 @@
Args = [PredTerm0, GoalTerm0],
term.coerce(PredTerm0, PredTerm1),
parse_purity_annotation(PredTerm1, DCGLambdaPurity, PredTerm),
- parse_dcg_pred_expression(PredTerm, EvalMethod, Vars0, Modes0, Det)
+ parse_dcg_pred_expression(PredTerm, Groundness, EvalMethod, Vars0,
+ Modes0, Det)
->
qualify_lambda_mode_list_if_not_opt_imported(Modes0, Modes, Context,
!QualInfo, !Specs),
@@ -602,10 +608,10 @@
MaybeParsedGoal = ok1(ParsedGoal),
Vars1 = Vars0 ++
[term.variable(DCG0, Context), term.variable(DCGn, Context)],
- build_lambda_expression(X, Purity, DCGLambdaPurity, pf_predicate,
- EvalMethod, Vars1, Modes, Det, ParsedGoal, Context, MainContext,
- SubContext, Goal0, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !.SInfo, !Specs),
+ build_lambda_expression(X, Purity, DCGLambdaPurity, Groundness,
+ pf_predicate, EvalMethod, Vars1, Modes, Det, ParsedGoal,
+ Context, MainContext, SubContext, Goal0, NumAdded, !VarSet,
+ !ModuleInfo, !QualInfo, !.SInfo, !Specs),
Goal0 = hlds_goal(GoalExpr, GoalInfo0),
goal_info_set_purity(Purity, GoalInfo0, GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo)
@@ -811,15 +817,15 @@
%
:- pred build_lambda_expression(prog_var::in, purity::in, purity::in,
- pred_or_func::in, lambda_eval_method::in, list(prog_term)::in,
- list(mer_mode)::in, determinism::in, goal::in, prog_context::in,
- unify_main_context::in, unify_sub_contexts::in,
+ ho_groundness::in, pred_or_func::in, lambda_eval_method::in,
+ list(prog_term)::in, list(mer_mode)::in, determinism::in, goal::in,
+ prog_context::in, unify_main_context::in, unify_sub_contexts::in,
hlds_goal::out, 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, list(error_spec)::in, list(error_spec)::out) is det.
-build_lambda_expression(X, UnificationPurity, LambdaPurity, PredOrFunc,
- EvalMethod, Args0, Modes, Det, ParsedGoal,
+build_lambda_expression(X, UnificationPurity, LambdaPurity, Groundness,
+ PredOrFunc, EvalMethod, Args0, Modes, Det, ParsedGoal,
Context, MainContext, SubContext, Goal, NumAdded,
!VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs) :-
% In the parse tree, the lambda arguments can be any terms, but in the HLDS
@@ -958,8 +964,8 @@
LambdaNonLocals = set.to_sorted_list(!.LambdaGoalVars)
),
- LambdaRHS = rhs_lambda_goal(LambdaPurity, PredOrFunc, EvalMethod,
- LambdaNonLocals, LambdaVars, Modes, Det, HLDS_Goal),
+ LambdaRHS = rhs_lambda_goal(LambdaPurity, Groundness, PredOrFunc,
+ EvalMethod, LambdaNonLocals, LambdaVars, Modes, Det, HLDS_Goal),
make_atomic_unification(X, LambdaRHS, Context, MainContext,
SubContext, UnificationPurity, Goal, !QualInfo)
).
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.138
diff -u -r1.138 switch_detection.m
--- compiler/switch_detection.m 30 Dec 2007 08:23:58 -0000 1.138
+++ compiler/switch_detection.m 8 Jan 2008 10:29:35 -0000
@@ -284,7 +284,7 @@
;
GoalExpr0 = unify(_, RHS0, _, _, _),
(
- RHS0 = rhs_lambda_goal(_, _, _, _, Vars, Modes, _, LambdaGoal0),
+ RHS0 = rhs_lambda_goal(_, _, _, _, _, Vars, Modes, _, LambdaGoal0),
% We need to insert the initial insts for the lambda variables
% in the instmap before processing the lambda goal.
instmap.pre_lambda_update(!.ModuleInfo, Vars, Modes,
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.187
diff -u -r1.187 type_util.m
--- compiler/type_util.m 30 Dec 2007 08:24:00 -0000 1.187
+++ compiler/type_util.m 8 Jan 2008 10:29:35 -0000
@@ -83,8 +83,11 @@
:- pred type_definitely_has_no_user_defined_equality_pred(module_info::in,
mer_type::in) is semidet.
- % Succeed iff the principal type constructor for the given type
- % is a solver type.
+ % Succeed iff the principal type constructor for the given type is
+ % declared a solver type, or if the type is a pred or func type. Pred
+ % and func types are considered solver types because higher-order terms
+ % that contain non-local solver variables are not ground unless all of
+ % the non-locals are ground.
%
% If the type is a type variable and thus has no principal type
% constructor, fail.
@@ -526,14 +529,18 @@
SolverTypeDetails ^ init_pred = solver_init_automatic(_).
type_is_solver_type(ModuleInfo, Type) :-
- type_to_type_defn_body(ModuleInfo, Type, TypeBody),
(
- TypeBody = hlds_solver_type(_, _)
+ type_is_higher_order(Type)
;
- TypeBody = hlds_abstract_type(solver_type)
- ;
- TypeBody = hlds_eqv_type(EqvType),
- type_is_solver_type(ModuleInfo, EqvType)
+ type_to_type_defn_body(ModuleInfo, Type, TypeBody),
+ (
+ TypeBody = hlds_solver_type(_, _)
+ ;
+ TypeBody = hlds_abstract_type(solver_type)
+ ;
+ TypeBody = hlds_eqv_type(EqvType),
+ type_is_solver_type(ModuleInfo, EqvType)
+ )
).
type_has_solver_type_details(ModuleInfo, Type, SolverTypeDetails) :-
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.427
diff -u -r1.427 typecheck.m
--- compiler/typecheck.m 23 Nov 2007 07:35:30 -0000 1.427
+++ compiler/typecheck.m 8 Jan 2008 10:29:35 -0000
@@ -1760,9 +1760,9 @@
typecheck_unify_var_functor(X, Functor, Args, GoalPath, !Info),
perform_context_reduction(!Info).
typecheck_unification(X,
- rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NonLocals, Vars, Modes, Det, Goal0),
- rhs_lambda_goal(Purity, PredOrFunc, EvalMethod,
+ rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
NonLocals, Vars, Modes, Det, Goal), _, !Info) :-
typecheck_lambda_var_has_type(Purity, PredOrFunc, EvalMethod, X, Vars,
!Info),
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.197
diff -u -r1.197 unify_proc.m
--- compiler/unify_proc.m 30 Dec 2007 08:24:01 -0000 1.197
+++ compiler/unify_proc.m 8 Jan 2008 10:29:35 -0000
@@ -731,7 +731,7 @@
InitCall = plain_call(PredId, ModeId, [X0], not_builtin, no, InitPred),
InitGoal = hlds_goal(InitCall, GoalInfo),
- Any = any(shared),
+ Any = any(shared, none),
generate_cast_with_insts(equiv_type_cast, X0, X, Any, Any, Context,
CastGoal),
Goal = hlds_goal(conj(plain_conj, [InitGoal, CastGoal]), GoalInfo),
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.125
diff -u -r1.125 unique_modes.m
--- compiler/unique_modes.m 30 Dec 2007 08:24:01 -0000 1.125
+++ compiler/unique_modes.m 8 Jan 2008 10:29:35 -0000
@@ -247,7 +247,7 @@
inst_expand(ModuleInfo0, Inst0, Inst1),
( Inst1 = ground(unique, _)
; Inst1 = bound(unique, _)
- ; Inst1 = any(unique)
+ ; Inst1 = any(unique, _)
)
->
make_mostly_uniq_inst(Inst0, Inst, ModuleInfo0, ModuleInfo),
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.147
diff -u -r1.147 unused_args.m
--- compiler/unused_args.m 30 Dec 2007 08:24:02 -0000 1.147
+++ compiler/unused_args.m 8 Jan 2008 10:29:35 -0000
@@ -726,7 +726,7 @@
set_var_used(LHS, !VarDep)
;
( RHS = rhs_functor(_, _, _)
- ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _)
+ ; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
),
unexpected(this_file,
"complicated unifications should only be var-var")
Index: compiler/unused_imports.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_imports.m,v
retrieving revision 1.12
diff -u -r1.12 unused_imports.m
--- compiler/unused_imports.m 30 Dec 2007 08:24:02 -0000 1.12
+++ compiler/unused_imports.m 8 Jan 2008 10:29:35 -0000
@@ -437,7 +437,7 @@
unify_rhs_used_modules(rhs_var(_), !UsedModules).
unify_rhs_used_modules(rhs_functor(ConsId, _, _), !UsedModules) :-
cons_id_used_modules(visibility_private, ConsId, !UsedModules).
-unify_rhs_used_modules(rhs_lambda_goal(_, _, _, _, _, _, _, Goal),
+unify_rhs_used_modules(rhs_lambda_goal(_, _, _, _, _, _, _, _, Goal),
!UsedModules) :-
hlds_goal_used_modules(Goal, !UsedModules).
@@ -519,15 +519,16 @@
:- pred mer_inst_used_modules(item_visibility::in, mer_inst::in,
used_modules::in, used_modules::out) is det.
-mer_inst_used_modules(_, any(_), !UsedModules).
+mer_inst_used_modules(Visibility, any(_, HOInstInfo), !UsedModules) :-
+ ho_inst_info_used_modules(Visibility, HOInstInfo, !UsedModules).
mer_inst_used_modules(_, free, !UsedModules).
mer_inst_used_modules(Visibility, free(Type), !UsedModules) :-
mer_type_used_modules(Visibility, Type, !UsedModules).
mer_inst_used_modules(Visibility, bound(_, BoundInsts), !UsedModules) :-
list.foldl(bound_inst_info_used_modules(Visibility), BoundInsts,
!UsedModules).
-mer_inst_used_modules(Visibility, ground(_, GroundInstInfo), !UsedModules) :-
- ground_inst_info_used_modules(Visibility, GroundInstInfo, !UsedModules).
+mer_inst_used_modules(Visibility, ground(_, HOInstInfo), !UsedModules) :-
+ ho_inst_info_used_modules(Visibility, HOInstInfo, !UsedModules).
mer_inst_used_modules(_, not_reached, !UsedModules).
mer_inst_used_modules(_, inst_var(_), !UsedModules).
mer_inst_used_modules(Visibility, constrained_inst_vars(_InstVars, Inst),
@@ -549,13 +550,13 @@
cons_id_used_modules(Visibility, ConsId, !UsedModules),
list.foldl(mer_inst_used_modules(Visibility), Insts, !UsedModules).
-:- pred ground_inst_info_used_modules(item_visibility::in,
- ground_inst_info::in, used_modules::in, used_modules::out) is det.
+:- pred ho_inst_info_used_modules(item_visibility::in,
+ ho_inst_info::in, used_modules::in, used_modules::out) is det.
-ground_inst_info_used_modules(Visibility,
+ho_inst_info_used_modules(Visibility,
higher_order(pred_inst_info(_, Modes, _)), !UsedModules) :-
list.foldl(mer_mode_used_modules(Visibility), Modes, !UsedModules).
-ground_inst_info_used_modules(_, none, !UsedModules).
+ho_inst_info_used_modules(_, none, !UsedModules).
%-----------------------------------------------------------------------------%
Index: compiler/xml_documentation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/xml_documentation.m,v
retrieving revision 1.19
diff -u -r1.19 xml_documentation.m
--- compiler/xml_documentation.m 30 Dec 2007 08:24:02 -0000 1.19
+++ compiler/xml_documentation.m 8 Jan 2008 10:29:35 -0000
@@ -576,7 +576,7 @@
:- func mer_inst(inst_varset, mer_inst) = xml.
-mer_inst(_, any(U)) = elem("any", [], [uniqueness(U)]).
+mer_inst(_, any(U, _)) = elem("any", [], [uniqueness(U)]).
mer_inst(_, free) = elem("free", [], []).
mer_inst(_, free(_)) = elem("free", [], []).
mer_inst(IVarset, bound(U, BoundInsts)) = Xml :-
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.414
diff -u -r1.414 reference_manual.texi
--- doc/reference_manual.texi 5 Dec 2007 05:07:42 -0000 1.414
+++ doc/reference_manual.texi 8 Jan 2008 10:29:36 -0000
@@ -2458,13 +2458,52 @@
@node Solver types and negated contexts
@subsection Solver types and negated contexts
-Referential transparency can be violated if a non-local solver type variable
-with inst @code{any} is used in a negated context (i.e., the body of a negated
-goal or the condition of an if-then-else) or in a lambda expression. Programs
-are therefore required to place such goals inside a @code{promise_pure},
- at code{promise_semipure}, or @code{promise_impure} scope, and to declare such
-lambda expressions to be @code{impure}, even if they would normally be
-considered pure.
+Mercury's negation and if-then-else goals
+(and hence also inequalities and universal quantifications)
+are implemented using @emph{negation as failure},
+meaning that the failure to find a proof of one statement is regarded as a
+proof of its negation.
+Negation as failure is sound provided that no non-local variable
+becomes further bound during the execution of a goal which may be negated.
+This includes negated goals themselves, as well as the conditions of
+if-then-elses, which are negated iff they fail without producing any solution,
+and the bodies of pred or func expressions, which may be called or applied
+in one of the other contexts, or indeed in another pred or func expression.
+
+Mercury checks that any solver variables that are used in the above contexts
+are used in such a way that negation as failure remains sound.
+In the case of negation and if-then-else goals,
+if any non-local solver type variable or higher order variable
+with inst @code{any} is used in a negated context,
+the goal must be placed inside a @code{promise_pure}, @code{promise_semipure},
+or @code{promise_impure} scope.
+The first two promises assert that (among other things)
+no solver variable becomes further bound in the negated context.
+The third promise makes the weaker assertion that the goal satisfies
+the requirements of all impure goals (namely, that it doesn't interfere
+with the semantics of other pure goals).
+
+In the case of pred and func expressions, Mercury allows three possibilities.
+The higher order value may be considered @code{ground}, which means that
+all non-local variables used in the body of the expression
+(including those with other higher order values) must themselves be ground.
+Higher order values that are ground can be safely called or applied
+in any context, including negated contexts, since none of their (ground)
+non-local variables can become further bound by doing so.
+Alternatively, the higher order value may be considered to have inst
+ at code{any}, which allows non-local variables used in the body of the
+expression to have inst @code{any}.
+Calling or applying these values @emph{may} further bind non-local variables,
+so if this occurs in a negated context then,
+as in the case of solver variables, a promise will be required around the
+negation or if-then-else.
+
+Pred and func expressions with inst @code{any} are written using
+ at code{any_pred} and @code{any_func} in place of @code{pred} and @code{func},
+respectively.
+
+The third possibility is that the higher order value can be given an
+impure type (@pxref{Higher-order impurity}).
@node Modes
@chapter Modes
@@ -4299,7 +4338,7 @@
The language contains builtin @samp{inst} values
@example
-pred is @var{Determinism}
+(pred) is @var{Determinism}
pred(@var{Mode}) is @var{Determinism}
pred(@var{Mode1}, @var{Mode2}) is @var{Determinism}
@dots{}
@@ -4388,6 +4427,21 @@
inst information may be lost, such as to a polymorphic predicate where the
argument mode is @samp{in}.
+Mercury also provides builtin @samp{inst} values for use with solver types:
+
+ at example
+any_pred is @var{Determinism}
+any_pred(@var{Mode}) is @var{Determinism}
+any_pred(@var{Mode1}, @var{Mode2}) is @var{Determinism}
+ at dots{}
+any_func = @var{Mode} is @var{Determinism}
+any_func(@var{Mode1}) = @var{Mode} is @var{Determinism}
+any_func(@var{Mode1}, @var{Mode2}) = @var{Mode} is @var{Determinism}
+ at dots{}
+ at end example
+
+See @ref{Solver types} for more details.
+
@node Modules
@chapter Modules
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.227
diff -u -r1.227 Mmakefile
--- tests/invalid/Mmakefile 5 Dec 2007 05:07:43 -0000 1.227
+++ tests/invalid/Mmakefile 8 Jan 2008 10:29:38 -0000
@@ -101,6 +101,7 @@
fundeps_unbound_in_ctor \
fundeps_vars \
hawkins_mm_fail_reset \
+ ho_any_inst \
ho_default_func_1 \
ho_default_func_3 \
ho_type_mode_bug \
Index: tests/invalid/anys_in_negated_contexts.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/anys_in_negated_contexts.err_exp,v
retrieving revision 1.3
diff -u -r1.3 anys_in_negated_contexts.err_exp
--- tests/invalid/anys_in_negated_contexts.err_exp 14 Jun 2006 08:14:52 -0000 1.3
+++ tests/invalid/anys_in_negated_contexts.err_exp 8 Jan 2008 10:29:38 -0000
@@ -13,9 +13,14 @@
anys_in_negated_contexts.m:071: messages indicate possible causes of this
anys_in_negated_contexts.m:071: error.
anys_in_negated_contexts.m:070: In clause for `bad_lambda(in)':
-anys_in_negated_contexts.m:070: purity error: lambda should be impure because
-anys_in_negated_contexts.m:070: it contains the following non-local variables
-anys_in_negated_contexts.m:070: whose insts contain `any': Y.
+anys_in_negated_contexts.m:070: purity error: lambda is `ground' but contains
+anys_in_negated_contexts.m:070: the following non-local variables whose insts
+anys_in_negated_contexts.m:070: contain `any': Y.
+anys_in_negated_contexts.m:070: Predicate expressions with inst `any' can be
+anys_in_negated_contexts.m:070: written `any_pred(Args) is det :- ...'.
+anys_in_negated_contexts.m:070: Function expressions with inst `any' can be
+anys_in_negated_contexts.m:070: written
+anys_in_negated_contexts.m:070: `any_func(Args) = Result is det :- ...'.
anys_in_negated_contexts.m:071: In clause for `bad_lambda(in)':
anys_in_negated_contexts.m:071: in argument 1 (i.e. the predicate term) of
anys_in_negated_contexts.m:071: higher-order predicate call:
Index: tests/invalid/ho_any_inst.err_exp
===================================================================
RCS file: tests/invalid/ho_any_inst.err_exp
diff -N tests/invalid/ho_any_inst.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_any_inst.err_exp 8 Jan 2008 10:29:38 -0000
@@ -0,0 +1,29 @@
+ho_any_inst.m:049: In clause for `cond0(in, out)':
+ho_any_inst.m:049: in higher-order predicate call:
+ho_any_inst.m:049: scope error: attempt to bind a non-local variable inside
+ho_any_inst.m:049: the condition of an if-then-else.
+ho_any_inst.m:049: Variable `P' has instantiatedness `(any_pred is semidet)',
+ho_any_inst.m:049: expected instantiatedness was `((pred) is semidet)'.
+ho_any_inst.m:057: In clause for `neg0(in)':
+ho_any_inst.m:057: in higher-order predicate call:
+ho_any_inst.m:057: scope error: attempt to bind a non-local variable inside a
+ho_any_inst.m:057: negation.
+ho_any_inst.m:057: Variable `P' has instantiatedness `(any_pred is semidet)',
+ho_any_inst.m:057: expected instantiatedness was `((pred) is semidet)'.
+ho_any_inst.m:061: In clause for `cond1(in, out)':
+ho_any_inst.m:061: in higher-order predicate call:
+ho_any_inst.m:061: scope error: attempt to bind a non-local variable inside
+ho_any_inst.m:061: the condition of an if-then-else.
+ho_any_inst.m:061: Variable `P' has instantiatedness `(any_pred((any >> any))
+ho_any_inst.m:061: is semidet)',
+ho_any_inst.m:061: expected instantiatedness was `(pred((any >> any)) is
+ho_any_inst.m:061: semidet)'.
+ho_any_inst.m:069: In clause for `neg1(in)':
+ho_any_inst.m:069: in higher-order predicate call:
+ho_any_inst.m:069: scope error: attempt to bind a non-local variable inside a
+ho_any_inst.m:069: negation.
+ho_any_inst.m:069: Variable `P' has instantiatedness `(any_pred((any >> any))
+ho_any_inst.m:069: is semidet)',
+ho_any_inst.m:069: expected instantiatedness was `(pred((any >> any)) is
+ho_any_inst.m:069: semidet)'.
+For more information, recompile with `-E'.
Index: tests/invalid/ho_any_inst.m
===================================================================
RCS file: tests/invalid/ho_any_inst.m
diff -N tests/invalid/ho_any_inst.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_any_inst.m 8 Jan 2008 10:29:38 -0000
@@ -0,0 +1,70 @@
+% vim: ts=4 sw=4 et
+:- module ho_any_inst.
+:- interface.
+
+% Test calling higher order terms that have `any' insts. It is an error
+% to call such a term in a negated context.
+
+:- solver type nat.
+
+:- func c(int::in) = (nat::oa) is det.
+:- pred eq(nat::ia, nat::ia) is semidet.
+
+:- pred p0(nat::ia, (pred)::out(any_pred is semidet)) is det.
+
+:- pred p1(nat::ia, pred(nat)::out(any_pred(ia) is semidet)) is det.
+
+:- pred cond0(int::in, int::out) is det.
+:- pred neg0(int::in) is semidet.
+
+:- pred cond1(int::in, int::out) is det.
+:- pred neg1(int::in) is semidet.
+
+:- implementation.
+
+:- solver type nat
+ where representation is int,
+ equality is eq.
+
+c(RA) = A :-
+ promise_pure (
+ impure A = 'representation to any nat/0'(RA)
+ ).
+
+eq(A, B) :-
+ promise_pure (
+ impure RA = 'representation of any nat/0'(A),
+ impure RB = 'representation of any nat/0'(B),
+ RA = RB
+ ).
+
+p0(A, Pred) :-
+ Pred = (any_pred is semidet :- eq(A, c(0))).
+
+p1(A, Pred) :-
+ Pred = (any_pred(B::ia) is semidet :- eq(A, B)).
+
+cond0(X, Y) :-
+ p0(c(X), P),
+ ( call(P) -> % Illegal!
+ Y = 1
+ ;
+ Y = 2
+ ).
+
+neg0(X) :-
+ p0(c(X), P),
+ \+ call(P). % Illegal!
+
+cond1(X, Y) :-
+ p1(c(X), P),
+ ( call(P, c(0)) -> % Illegal!
+ Y = 1
+ ;
+ Y = 2
+ ).
+
+neg1(X) :-
+ p1(c(X), P),
+ \+ call(P, c(0)). % Illegal!
+
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.203
diff -u -r1.203 Mmakefile
--- tests/valid/Mmakefile 3 Dec 2007 09:52:14 -0000 1.203
+++ tests/valid/Mmakefile 8 Jan 2008 10:29:38 -0000
@@ -235,6 +235,7 @@
intermod_pragma_import
SOLVER_PROGS = \
+ ho_any_inst \
solv \
solver_type_bug_2
Index: tests/valid/ho_any_inst.m
===================================================================
RCS file: tests/valid/ho_any_inst.m
diff -N tests/valid/ho_any_inst.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/ho_any_inst.m 8 Jan 2008 10:29:38 -0000
@@ -0,0 +1,83 @@
+% vim: ts=4 sw=4 et
+:- module ho_any_inst.
+:- interface.
+
+% Test creating and calling higher order terms that have `any' insts,
+% including terms that have non-local variables with `any' insts.
+
+:- solver type nat.
+
+:- func c(int::in) = (nat::oa) is det.
+:- pred eq(nat::ia, nat::ia) is semidet.
+
+:- pred p0(nat::ia, (pred)::out(any_pred is semidet)) is det.
+:- pred call_p0((pred)::in(any_pred is semidet)) is semidet.
+
+:- pred p1(nat::ia, pred(nat)::out(any_pred(ia) is semidet)) is det.
+:- pred call_p1(pred(nat)::in(any_pred(ia) is semidet), nat::ia) is semidet.
+
+:- pred p2(nat::ia, nat::ia, pred(nat, nat)::out(any_pred(ia, ia) is semidet))
+ is det.
+:- pred call_p2(pred(nat, nat)::in(any_pred(ia, ia) is semidet),
+ nat::ia, nat::ia) is semidet.
+:- pred partial_call_p2(pred(nat, nat)::in(any_pred(ia, ia) is semidet),
+ nat::ia, pred(nat)::out(any_pred(ia) is semidet)) is det.
+
+:- func f0(nat::ia) = (((func) = nat)::out(any_func = ia is semidet)) is det.
+:- func apply_f0(((func) = nat)::in(any_func = ia is semidet)) = (nat::ia)
+ is semidet.
+
+:- func f1(nat::ia) = ((func(nat) = nat)::out(any_func(ia) = ia is semidet))
+ is det.
+:- func apply_f1((func(nat) = nat)::in(any_func(ia) = ia is semidet), nat::ia)
+ = (nat::ia) is semidet.
+
+:- implementation.
+
+:- solver type nat
+ where representation is int,
+ equality is eq.
+
+c(RA) = A :-
+ promise_pure (
+ impure A = 'representation to any nat/0'(RA)
+ ).
+
+eq(A, B) :-
+ promise_pure (
+ impure RA = 'representation of any nat/0'(A),
+ impure RB = 'representation of any nat/0'(B),
+ RA = RB
+ ).
+
+p0(A, Pred) :-
+ Pred = (any_pred is semidet :- eq(A, c(0))).
+
+call_p0(Pred) :-
+ call(Pred).
+
+p1(A, Pred) :-
+ Pred = (any_pred(B::ia) is semidet :- eq(A, B)).
+
+call_p1(Pred, B) :-
+ call(Pred, B).
+
+p2(A1, A2, Pred) :-
+ Pred = (any_pred(B1::ia, B2::ia) is semidet :- eq(A1, A2), eq(B1, B2)).
+
+call_p2(Pred, B1, B2) :-
+ call(Pred, B1, B2).
+
+partial_call_p2(Pred2, _B1, Pred1) :-
+ Pred1 = (any_pred(B2::ia) is semidet :- Pred2(c(0), B2)).
+
+f0(A) = (any_func = (B::ia) is semidet :- eq(A, B)).
+
+apply_f0(Func) = B :-
+ apply(Func) = B.
+
+f1(A) = (any_func(_B::ia) = (C::ia) is semidet :- eq(A, C)).
+
+apply_f1(Func, B) = C :-
+ apply(Func, B) = C.
+
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at csse.unimelb.edu.au
Administrative Queries: owner-mercury-developers at csse.unimelb.edu.au
Subscriptions: mercury-developers-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the developers
mailing list