[m-dev.] for review: fix existential types bug
Fergus Henderson
fjh at cs.mu.OZ.AU
Fri Oct 15 04:14:09 AEST 1999
This change fixes the existential types problem that
Peter Ross reported recently on the mercury-users list.
If this passes bootcheck, then I will probably go ahead
and commit it without waiting for review.
--------------------
Estimated hours taken: 12
Fix a bug with switches on existential types. This bug meant that
existential types with two or more functors did not work at all,
due to internal compiler errors when compiling the unification and
comparison predicates for those types.
compiler/type_util.m:
Add new function cons_id_adjusted_arity, which computes the
arity _including_ the extra typeinfo and typeclassinfo
arguments inserted for existential data types.
compiler/type_util.m:
compiler/polymorphism.m:
Move the predicates constraint_list_get_tvars
and constraint_get_tvars from polymorphism.m into
type_util.m, for use in cons_id_adjusted_arity.
compiler/modes.m:
compiler/unique_modes.m:
When modechecking the functor test in switch statements,
use cons_id_adjusted_arity to compute the arity of the inst.
compiler/instmap.m:
In instmap__bind_var_to_functor (and the instmap_delta version),
use cons_id_adjusted_arity to compute the arity of the inst.
compiler/goal_util.m:
compiler/pd_info.m:
compiler/pd_util.m:
compiler/saved_vars.m:
compiler/mode_util.m:
compiler/deforest.m:
compiler/follow_code.m:
compiler/higher_order.m:
compiler/simplify.m:
Pass the type(s) down to recompute_instmap_delta and
instmap__bind_var_to_functor, since cons_id_adjusted_arity
needs to know the type.
compiler/hlds_pred.m:
compiler/hlds_out.m:
Add a `vartypes' typedef, defined by `:- type vartypes == map(prog_var, type)',
and make use of it. Rename the `vartypes' type in hlds_out as `maybe_vartypes'.
tests/hard_coded/Mmakefile:
tests/hard_coded/existential_type_switch.m:
tests/hard_coded/existential_type_switch.exp:
Add a regression test.
tests/hard_coded/Mmakefile:
Enable the existential_types_test.m test case,
which should have been enabled previously.
(The reason that it wasn't seems to be that I made
a mistake when merging in the changes from the
existential types branch.)
Workspace: /d-drive/home/hg/fjh/mercury
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.10
diff -u -r1.10 deforest.m
--- compiler/deforest.m 1999/07/13 08:52:46 1.10
+++ compiler/deforest.m 1999/10/14 15:56:45
@@ -121,8 +121,9 @@
{ proc_info_goal(ProcInfo3, Goal3) },
{ proc_info_get_initial_instmap(ProcInfo3,
ModuleInfo2, InstMap0) },
+ { proc_info_vartypes(ProcInfo3, VarTypes) },
{ recompute_instmap_delta(yes, Goal3, Goal,
- InstMap0, ModuleInfo2, ModuleInfo3) },
+ VarTypes, InstMap0, ModuleInfo2, ModuleInfo3) },
pd_info_set_module_info(ModuleInfo3),
pd_info_get_pred_info(PredInfo),
Index: compiler/follow_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_code.m,v
retrieving revision 1.52
diff -u -r1.52 follow_code.m
--- compiler/follow_code.m 1999/07/13 08:52:53 1.52
+++ compiler/follow_code.m 1999/10/14 15:51:11
@@ -57,7 +57,7 @@
Varset0, VarTypes0, Goal2, Varset, VarTypes, _Warnings),
proc_info_get_initial_instmap(ProcInfo0,
ModuleInfo0, InstMap0),
- recompute_instmap_delta(no, Goal2, Goal, InstMap0,
+ recompute_instmap_delta(no, Goal2, Goal, VarTypes, InstMap0,
ModuleInfo0, ModuleInfo)
;
Goal = Goal0,
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.56
diff -u -r1.56 goal_util.m
--- compiler/goal_util.m 1999/09/30 23:08:20 1.56
+++ compiler/goal_util.m 1999/10/11 15:26:14
@@ -899,7 +899,7 @@
UniMode, Unification, UnifyContext),
set__singleton_set(NonLocals, Var),
instmap_delta_init_reachable(ExtraInstMapDelta0),
- instmap_delta_bind_var_to_functor(Var, ConsId, InstMap,
+ instmap_delta_bind_var_to_functor(Var, VarType, ConsId, InstMap,
ExtraInstMapDelta0, ExtraInstMapDelta,
ModuleInfo0, ModuleInfo),
goal_info_init(NonLocals, ExtraInstMapDelta, semidet, ExtraGoalInfo),
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.56
diff -u -r1.56 higher_order.m
--- compiler/higher_order.m 1999/10/03 04:15:21 1.56
+++ compiler/higher_order.m 1999/10/14 15:51:59
@@ -391,8 +391,9 @@
proc_info_goal(ProcInfo2, Goal2),
RecomputeAtomic = no,
proc_info_get_initial_instmap(ProcInfo2, ModuleInfo0, InstMap),
- recompute_instmap_delta(RecomputeAtomic, Goal2, Goal3, InstMap,
- ModuleInfo0, ModuleInfo),
+ proc_info_vartypes(ProcInfo2, VarTypes),
+ recompute_instmap_delta(RecomputeAtomic, Goal2, Goal3,
+ VarTypes, InstMap, ModuleInfo0, ModuleInfo),
proc_info_set_goal(ProcInfo2, Goal3, ProcInfo),
Info = info(A, B, C, D, E, ProcInfo, ModuleInfo, H, Changed)
;
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.225
diff -u -r1.225 hlds_out.m
--- compiler/hlds_out.m 1999/09/12 04:26:41 1.225
+++ compiler/hlds_out.m 1999/10/14 15:40:28
@@ -34,7 +34,7 @@
:- import_module hlds_module, hlds_pred, hlds_goal, hlds_data.
:- import_module prog_data, llds, instmap, term.
-:- import_module io, bool, map, list, term.
+:- import_module io, bool, list, term.
%-----------------------------------------------------------------------------%
@@ -137,13 +137,13 @@
:- mode hlds_out__write_hlds(in, in, di, uo) is det.
:- pred hlds_out__write_clauses(int, module_info, pred_id, prog_varset, bool,
- list(prog_var), pred_or_func, list(clause), vartypes,
+ list(prog_var), pred_or_func, list(clause), maybe_vartypes,
io__state, io__state).
:- mode hlds_out__write_clauses(in, in, in, in, in, in, in, in, in, di, uo)
is det.
:- pred hlds_out__write_assertion(int, module_info, pred_id, prog_varset, bool,
- list(prog_var), pred_or_func, clause, vartypes,
+ list(prog_var), pred_or_func, clause, maybe_vartypes,
io__state, io__state).
:- mode hlds_out__write_assertion(in, in, in, in, in, in, in, in, in, di, uo)
is det.
@@ -159,16 +159,17 @@
string, io__state, io__state).
:- mode hlds_out__write_goal(in, in, in, in, in, in, di, uo) is det.
- % hlds_out__write_goal_list is used to write both disjunctions and
- % parallel conjunctions. The module_info, prog_varset and vartypes give
- % the context of the goal. The boolean says whether variables should
- % have their numbers appended to them. The integer gives the level
- % of indentation to be used within the goal. The string says what
- % should be on the line between each goal; it should include a newline
- % character, but may also contain other characters before that.
+ % hlds_out__write_goal_list is used to write both disjunctions
+ % and parallel conjunctions. The module_info, prog_varset and
+ % maybe_vartypes give the context of the goal. The boolean
+ % says whether variables should have their numbers appended to
+ % them. The integer gives the level of indentation to be used
+ % within the goal. The string says what should be on the line
+ % between each goal; it should include a newline character,
+ % but may also contain other characters before that.
:- pred hlds_out__write_goal_list(list(hlds_goal), module_info, prog_varset,
- bool, int, string, vartypes, io__state, io__state).
+ bool, int, string, maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_goal_list(in, in, in, in, in, in, in, di, uo) is det.
% Print out a functor and its arguments. The prog_varset gives
@@ -219,8 +220,8 @@
:- pred hlds_out__write_marker(marker, io__state, io__state).
:- mode hlds_out__write_marker(in, di, uo) is det.
-:- type vartypes --->
- yes(tvarset, map(prog_var, type))
+:- type maybe_vartypes
+ ---> yes(tvarset, vartypes)
; no.
%-----------------------------------------------------------------------------%
@@ -232,7 +233,7 @@
:- import_module llds_out, prog_out, prog_util, (inst), instmap, trace.
:- import_module rl, termination, term_errors, check_typeclass.
-:- import_module int, string, set, assoc_list, multi_map.
+:- import_module int, string, set, assoc_list, map, multi_map.
:- import_module require, getopt, std_util, term_io, varset.
@@ -854,7 +855,7 @@
).
:- pred hlds_out__write_clause(int, module_info, pred_id, prog_varset, bool,
- list(prog_var), pred_or_func, clause, vartypes,
+ list(prog_var), pred_or_func, clause, maybe_vartypes,
io__state, io__state).
:- mode hlds_out__write_clause(in, in, in, in, in, in, in, in, in, di, uo)
is det.
@@ -955,7 +956,7 @@
% TypeQual is yes(TVarset, VarTypes) if all constructors should
% be module qualified.
:- pred hlds_out__write_goal_a(hlds_goal, module_info, prog_varset, bool, int,
- string, vartypes, io__state, io__state).
+ string, maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_goal_a(in, in, in, in, in, in, in, di, uo) is det.
hlds_out__write_goal_a(Goal - GoalInfo, ModuleInfo, VarSet, AppendVarnums,
@@ -1165,7 +1166,7 @@
).
:- pred hlds_out__write_goal_2(hlds_goal_expr, module_info, prog_varset, bool,
- int, string, vartypes, io__state, io__state).
+ int, string, maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_goal_2(in, in, in, in, in, in, in, di, uo) is det.
hlds_out__write_goal_2(switch(Var, CanFail, CasesList, _), ModuleInfo, VarSet,
@@ -1787,7 +1788,7 @@
AppendVarnums, Indent, no, no).
:- pred hlds_out__write_unify_rhs_2(unify_rhs, module_info, prog_varset,
- inst_varset, bool, int, string, maybe(type), vartypes,
+ inst_varset, bool, int, string, maybe(type), maybe_vartypes,
io__state, io__state).
:- mode hlds_out__write_unify_rhs_2(in, in, in, in, in, in, in, in, in, di, uo)
is det.
@@ -1799,7 +1800,7 @@
io__write_string(Follow).
:- pred hlds_out__write_unify_rhs_3(unify_rhs, module_info, prog_varset,
- inst_varset, bool, int, maybe(type), vartypes, io__state, io__state).
+ inst_varset, bool, int, maybe(type), maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_unify_rhs_3(in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -2022,7 +2023,7 @@
mercury_output_mode(Mode, InstVarSet).
:- pred hlds_out__write_conj(hlds_goal, list(hlds_goal), module_info,
- prog_varset, bool, int, string, string, string, vartypes,
+ prog_varset, bool, int, string, string, string, maybe_vartypes,
io__state, io__state).
:- mode hlds_out__write_conj(in, in, in, in, in, in, in, in, in, in,
di, uo) is det.
@@ -2071,7 +2072,7 @@
).
:- pred hlds_out__write_case(case, prog_var, module_info, prog_varset, bool,
- int, vartypes, io__state, io__state).
+ int, maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_case(in, in, in, in, in, in, in, di, uo) is det.
hlds_out__write_case(case(ConsId, Goal), Var, ModuleInfo, VarSet,
@@ -2091,7 +2092,7 @@
Indent, "\n", VarTypes).
:- pred hlds_out__write_cases(list(case), prog_var, module_info, prog_varset,
- bool, int, vartypes, io__state, io__state).
+ bool, int, maybe_vartypes, io__state, io__state).
:- mode hlds_out__write_cases(in, in, in, in, in, in, in, di, uo) is det.
hlds_out__write_cases(CasesList, Var, ModuleInfo, VarSet, AppendVarnums,
@@ -2177,7 +2178,7 @@
hlds_out__write_import_status(exported_to_submodules) -->
io__write_string("exported_to_submodules").
-:- pred hlds_out__write_var_types(int, prog_varset, bool, map(prog_var, type),
+:- pred hlds_out__write_var_types(int, prog_varset, bool, vartypes,
tvarset, io__state, io__state).
:- mode hlds_out__write_var_types(in, in, in, in, in, di, uo) is det.
@@ -2189,7 +2190,7 @@
VarTypes, TVarSet).
:- pred hlds_out__write_var_types_2(list(prog_var), int, prog_varset, bool,
- map(prog_var, type), tvarset, io__state, io__state).
+ vartypes, tvarset, io__state, io__state).
:- mode hlds_out__write_var_types_2(in, in, in, in, in, in, di, uo) is det.
hlds_out__write_var_types_2([], _, _, _, _, _) --> [].
@@ -2873,8 +2874,7 @@
% { error("This cannot happen") }
% ).
-:- pred hlds_out__write_vartypes(int, map(prog_var, type),
- io__state, io__state).
+:- pred hlds_out__write_vartypes(int, vartypes, io__state, io__state).
:- mode hlds_out__write_vartypes(in, in, di, uo) is det.
hlds_out__write_vartypes(Indent, X) -->
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.65
diff -u -r1.65 hlds_pred.m
--- compiler/hlds_pred.m 1999/08/18 10:03:00 1.65
+++ compiler/hlds_pred.m 1999/10/14 15:28:46
@@ -112,10 +112,10 @@
% the optimized goal can be compared with the original in HLDS dumps.
:- type clauses_info ---> clauses_info(
prog_varset, % variable names
- map(prog_var, type),
+ vartypes,
% variable types from
% explicit qualifications
- map(prog_var, type),
+ vartypes,
% variable types
% inferred by typecheck.m.
list(prog_var), % head vars
@@ -127,17 +127,19 @@
typeclass_info_varmap
).
+:- type vartypes == map(prog_var, type).
+
:- pred clauses_info_varset(clauses_info, prog_varset).
:- mode clauses_info_varset(in, out) is det.
% This partial map holds the types specified by any explicit
% type qualifiers in the clauses.
-:- pred clauses_info_explicit_vartypes(clauses_info, map(prog_var, type)).
+:- pred clauses_info_explicit_vartypes(clauses_info, vartypes).
:- mode clauses_info_explicit_vartypes(in, out) is det.
% This map contains the types of all the variables, as inferred
% by typecheck.m.
-:- pred clauses_info_vartypes(clauses_info, map(prog_var, type)).
+:- pred clauses_info_vartypes(clauses_info, vartypes).
:- mode clauses_info_vartypes(in, out) is det.
:- pred clauses_info_type_info_varmap(clauses_info, type_info_varmap).
@@ -164,13 +166,13 @@
% This partial map holds the types specified by any explicit
% type qualifiers in the clauses.
-:- pred clauses_info_set_explicit_vartypes(clauses_info, map(prog_var, type),
+:- pred clauses_info_set_explicit_vartypes(clauses_info, vartypes,
clauses_info).
:- mode clauses_info_set_explicit_vartypes(in, in, out) is det.
% This map contains the types of all the variables, as inferred
% by typecheck.m.
-:- pred clauses_info_set_vartypes(clauses_info, map(prog_var, type),
+:- pred clauses_info_set_vartypes(clauses_info, vartypes,
clauses_info).
:- mode clauses_info_set_vartypes(in, in, out) is det.
@@ -442,7 +444,7 @@
% type_infos and typeclass_infos required by typeinfo liveness
% which were added to the front of the argument list.
:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(prog_var),
- list(prog_var), instmap, string, tvarset, map(prog_var, type),
+ list(prog_var), instmap, string, tvarset, vartypes,
class_constraints, type_info_varmap, typeclass_info_varmap,
prog_varset, pred_markers, aditi_owner, is_address_taken,
module_info, module_info, pred_proc_id).
@@ -1166,10 +1168,10 @@
% :- type clauses_info ---> clauses_info(
% prog_varset, % variable names
-% map(prog_var, type),
+% vartypes,
% % variable types from
% % explicit qualifications
-% map(prog_var, type),
+% vartypes,
% % variable types
% % inferred by typecheck.m.
% list(prog_var), % head vars
@@ -1281,7 +1283,7 @@
Goal = GoalExpr - GoalInfo,
PredProcId = proc(PredId, ProcId).
-:- pred compute_arg_types_modes(list(prog_var)::in, map(prog_var, type)::in,
+:- pred compute_arg_types_modes(list(prog_var)::in, vartypes::in,
instmap::in, instmap::in, list(type)::out, list(mode)::out) is det.
compute_arg_types_modes([], _, _, _, [], []).
@@ -1310,7 +1312,7 @@
is_address_taken, proc_info).
:- mode proc_info_init(in, in, in, in, in, in, in, in, out) is det.
-:- pred proc_info_set(maybe(determinism), prog_varset, map(prog_var, type),
+:- pred proc_info_set(maybe(determinism), prog_varset, vartypes,
list(prog_var), list(mode), maybe(list(is_live)), hlds_goal,
prog_context, stack_slots, determinism, bool, list(arg_info),
liveness_info, type_info_varmap, typeclass_info_varmap,
@@ -1319,12 +1321,12 @@
:- mode proc_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
in, in, in, in, out) is det.
-:- pred proc_info_create(prog_varset, map(prog_var, type), list(prog_var),
+:- pred proc_info_create(prog_varset, vartypes, list(prog_var),
list(mode), determinism, hlds_goal, prog_context,
type_info_varmap, typeclass_info_varmap, is_address_taken, proc_info).
:- mode proc_info_create(in, in, in, in, in, in, in, in, in, in, out) is det.
-:- pred proc_info_set_body(proc_info, prog_varset, map(prog_var, type),
+:- pred proc_info_set_body(proc_info, prog_varset, vartypes,
list(prog_var), hlds_goal, type_info_varmap,
typeclass_info_varmap, proc_info).
:- mode proc_info_set_body(in, in, in, in, in, in, in, out) is det.
@@ -1354,10 +1356,10 @@
:- pred proc_info_set_varset(proc_info, prog_varset, proc_info).
:- mode proc_info_set_varset(in, in, out) is det.
-:- pred proc_info_vartypes(proc_info, map(prog_var, type)).
+:- pred proc_info_vartypes(proc_info, vartypes).
:- mode proc_info_vartypes(in, out) is det.
-:- pred proc_info_set_vartypes(proc_info, map(prog_var, type), proc_info).
+:- pred proc_info_set_vartypes(proc_info, vartypes, proc_info).
:- mode proc_info_set_vartypes(in, in, out) is det.
:- pred proc_info_headvars(proc_info, list(prog_var)).
@@ -1523,8 +1525,7 @@
% _declared_ determinism
% or `no' if there was no detism decl
prog_varset, % variable names
- map(prog_var, type),
- % variable types
+ vartypes, % variable types
list(prog_var), % head vars
list(mode), % modes of args
maybe(list(is_live)),
Index: compiler/instmap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/instmap.m,v
retrieving revision 1.24
diff -u -r1.24 instmap.m
--- compiler/instmap.m 1999/06/15 07:09:54 1.24
+++ compiler/instmap.m 1999/10/14 16:13:03
@@ -165,13 +165,13 @@
% Bind a variable in an instmap to a functor at the beginning
% of a case in a switch. Aborts on compiler generated cons_ids.
-:- pred instmap_delta_bind_var_to_functor(prog_var, cons_id, instmap,
+:- pred instmap_delta_bind_var_to_functor(prog_var, type, cons_id, instmap,
instmap_delta, instmap_delta, module_info, module_info).
-:- mode instmap_delta_bind_var_to_functor(in, in, in, in, out, in, out) is det.
+:- mode instmap_delta_bind_var_to_functor(in, in, in, in, in, out, in, out) is det.
-:- pred instmap__bind_var_to_functor(prog_var, cons_id,
+:- pred instmap__bind_var_to_functor(prog_var, type, cons_id,
instmap, instmap, module_info, module_info).
-:- mode instmap__bind_var_to_functor(in, in, in, out, in, out) is det.
+:- mode instmap__bind_var_to_functor(in, in, in, in, out, in, out) is det.
% Update the given instmap to include the initial insts of the
% lambda variables.
@@ -305,15 +305,15 @@
:- implementation.
-:- import_module mode_util, inst_match, prog_data, goal_util.
-:- import_module hlds_data, inst_util, term.
+:- import_module mode_util, inst_match, prog_data, goal_util, type_util.
+:- import_module hlds_data, inst_util.
-:- import_module std_util, require, string.
+:- import_module std_util, require, string, term.
:- type instmap_delta == instmap.
:- type instmap ---> reachable(instmapping)
- ; unreachable.
+ ; unreachable.
:- type instmapping == map(prog_var, inst).
@@ -480,7 +480,7 @@
%-----------------------------------------------------------------------------%
-instmap_delta_bind_var_to_functor(Var, ConsId, InstMap,
+instmap_delta_bind_var_to_functor(Var, Type, ConsId, InstMap,
InstmapDelta0, InstmapDelta, ModuleInfo0, ModuleInfo) :-
(
InstmapDelta0 = unreachable,
@@ -504,7 +504,7 @@
;
NewInst1 = OldInst
),
- bind_inst_to_functor(NewInst1, ConsId, NewInst,
+ bind_inst_to_functor(Type, ConsId, NewInst1, NewInst,
ModuleInfo0, ModuleInfo),
%
@@ -518,18 +518,19 @@
)
).
-instmap__bind_var_to_functor(Var, ConsId, InstMap0, InstMap,
+instmap__bind_var_to_functor(Var, Type, ConsId, InstMap0, InstMap,
ModuleInfo0, ModuleInfo) :-
instmap__lookup_var(InstMap0, Var, Inst0),
- bind_inst_to_functor(Inst0, ConsId, Inst, ModuleInfo0, ModuleInfo),
+ bind_inst_to_functor(Type, ConsId, Inst0, Inst,
+ ModuleInfo0, ModuleInfo),
instmap__set(InstMap0, Var, Inst, InstMap).
-:- pred bind_inst_to_functor((inst), cons_id, (inst),
+:- pred bind_inst_to_functor(type, cons_id, (inst), (inst),
module_info, module_info).
-:- mode bind_inst_to_functor(in, in, out, in, out) is det.
+:- mode bind_inst_to_functor(in, in, in, out, in, out) is det.
-bind_inst_to_functor(Inst0, ConsId, Inst, ModuleInfo0, ModuleInfo) :-
- cons_id_arity(ConsId, Arity),
+bind_inst_to_functor(Type, ConsId, Inst0, Inst, ModuleInfo0, ModuleInfo) :-
+ Arity = cons_id_adjusted_arity(ModuleInfo0, Type, ConsId),
list__duplicate(Arity, dead, ArgLives),
list__duplicate(Arity, free, ArgInsts),
(
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.116
diff -u -r1.116 mode_util.m
--- compiler/mode_util.m 1999/07/13 08:53:14 1.116
+++ compiler/mode_util.m 1999/10/14 16:11:25
@@ -108,9 +108,9 @@
% may need to insert new merge_insts into the merge_inst table.
% If the first argument is yes, the instmap_deltas for calls
% and deconstruction unifications are also recomputed.
-:- pred recompute_instmap_delta(bool, hlds_goal, hlds_goal, instmap,
+:- pred recompute_instmap_delta(bool, hlds_goal, hlds_goal, vartypes, instmap,
module_info, module_info).
-:- mode recompute_instmap_delta(in, in, out, in, in, out) is det.
+:- mode recompute_instmap_delta(in, in, out, in, in, in, out) is det.
% Given corresponding lists of types and modes, produce a new
% list of modes which includes the information provided by the
@@ -1076,15 +1076,15 @@
% and deconstructions may become non-local (XXX does this require
% rerunning mode analysis rather than just recompute_instmap_delta?).
-recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, InstMap0) -->
- recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, InstMap0, _).
+recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap0) -->
+ recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap0, _).
-:- pred recompute_instmap_delta(bool, hlds_goal, hlds_goal, instmap,
+:- pred recompute_instmap_delta(bool, hlds_goal, hlds_goal, vartypes, instmap,
instmap_delta, module_info, module_info).
-:- mode recompute_instmap_delta(in, in, out, in, out, in, out) is det.
+:- mode recompute_instmap_delta(in, in, out, in, in, out, in, out) is det.
recompute_instmap_delta(RecomputeAtomic, Goal0 - GoalInfo0, Goal - GoalInfo,
- InstMap0, InstMapDelta) -->
+ VarTypes, InstMap0, InstMapDelta) -->
(
{ RecomputeAtomic = no },
(
@@ -1099,7 +1099,7 @@
{ GoalInfo1 = GoalInfo0 }
;
recompute_instmap_delta_2(RecomputeAtomic, Goal0,
- GoalInfo0, Goal, InstMap0, InstMapDelta0),
+ GoalInfo0, Goal, VarTypes, InstMap0, InstMapDelta0),
{ goal_info_get_nonlocals(GoalInfo0, NonLocals) },
{ instmap_delta_restrict(InstMapDelta0,
NonLocals, InstMapDelta1) },
@@ -1118,44 +1118,45 @@
{ goal_info_get_instmap_delta(GoalInfo, InstMapDelta) }.
:- pred recompute_instmap_delta_2(bool, hlds_goal_expr, hlds_goal_info,
- hlds_goal_expr, instmap, instmap_delta,
+ hlds_goal_expr, vartypes, instmap, instmap_delta,
module_info, module_info).
-:- mode recompute_instmap_delta_2(in, in, in, out, in, out, in, out) is det.
+:- mode recompute_instmap_delta_2(in, in, in, out, in, in, out, in, out) is det.
recompute_instmap_delta_2(Atomic, switch(Var, Det, Cases0, SM), GoalInfo,
- switch(Var, Det, Cases, SM), InstMap, InstMapDelta) -->
+ switch(Var, Det, Cases, SM), VarTypes, InstMap,
+ InstMapDelta) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
recompute_instmap_delta_cases(Atomic, Var, Cases0, Cases,
- InstMap, NonLocals, InstMapDelta).
+ VarTypes, InstMap, NonLocals, InstMapDelta).
recompute_instmap_delta_2(Atomic, conj(Goals0), _, conj(Goals),
- InstMap, InstMapDelta) -->
+ VarTypes, InstMap, InstMapDelta) -->
recompute_instmap_delta_conj(Atomic, Goals0, Goals,
- InstMap, InstMapDelta).
+ VarTypes, InstMap, InstMapDelta).
recompute_instmap_delta_2(Atomic, par_conj(Goals0, SM), GoalInfo,
- par_conj(Goals, SM), InstMap, InstMapDelta) -->
+ par_conj(Goals, SM), VarTypes, InstMap, InstMapDelta) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
recompute_instmap_delta_par_conj(Atomic, Goals0, Goals,
- InstMap, NonLocals, InstMapDelta).
+ VarTypes, InstMap, NonLocals, InstMapDelta).
recompute_instmap_delta_2(Atomic, disj(Goals0, SM), GoalInfo, disj(Goals, SM),
- InstMap, InstMapDelta) -->
+ VarTypes, InstMap, InstMapDelta) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
recompute_instmap_delta_disj(Atomic, Goals0, Goals,
- InstMap, NonLocals, InstMapDelta).
+ VarTypes, InstMap, NonLocals, InstMapDelta).
recompute_instmap_delta_2(Atomic, not(Goal0), _, not(Goal),
- InstMap, InstMapDelta) -->
+ VarTypes, InstMap, InstMapDelta) -->
{ instmap_delta_init_reachable(InstMapDelta) },
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap).
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap).
recompute_instmap_delta_2(Atomic, if_then_else(Vars, A0, B0, C0, SM), GoalInfo,
- if_then_else(Vars, A, B, C, SM), InstMap0, InstMapDelta) -->
- recompute_instmap_delta(Atomic, A0, A, InstMap0, InstMapDelta1),
+ if_then_else(Vars, A, B, C, SM), VarTypes, InstMap0, InstMapDelta) -->
+ recompute_instmap_delta(Atomic, A0, A, VarTypes, InstMap0, InstMapDelta1),
{ instmap__apply_instmap_delta(InstMap0, InstMapDelta1, InstMap1) },
- recompute_instmap_delta(Atomic, B0, B, InstMap1, InstMapDelta2),
- recompute_instmap_delta(Atomic, C0, C, InstMap0, InstMapDelta3),
+ recompute_instmap_delta(Atomic, B0, B, VarTypes, InstMap1, InstMapDelta2),
+ recompute_instmap_delta(Atomic, C0, C, VarTypes, InstMap0, InstMapDelta3),
{ instmap_delta_apply_instmap_delta(InstMapDelta1, InstMapDelta2,
InstMapDelta4) },
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
@@ -1164,23 +1165,25 @@
recompute_instmap_delta_2(Atomic, some(Vars, CanRemove, Goal0), _,
some(Vars, CanRemove, Goal),
- InstMap, InstMapDelta) -->
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap, InstMapDelta).
+ VarTypes, InstMap, InstMapDelta) -->
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap, InstMapDelta).
recompute_instmap_delta_2(_, generic_call(A, Vars, Modes, D), _,
generic_call(A, Vars, Modes, D),
- _InstMap, InstMapDelta) -->
+ _VarTypes, _InstMap, InstMapDelta) -->
=(ModuleInfo),
{ instmap_delta_from_mode_list(Vars, Modes,
ModuleInfo, InstMapDelta) }.
recompute_instmap_delta_2(_, call(PredId, ProcId, Args, D, E, F), _,
- call(PredId, ProcId, Args, D, E, F), InstMap, InstMapDelta) -->
+ call(PredId, ProcId, Args, D, E, F), _VarTypes,
+ InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Args, InstMap, InstMapDelta).
recompute_instmap_delta_2(Atomic, unify(A, Rhs0, UniMode0, Uni, E), GoalInfo,
- unify(A, Rhs, UniMode, Uni, E), InstMap0, InstMapDelta) -->
+ unify(A, Rhs, UniMode, Uni, E), VarTypes, InstMap0,
+ InstMapDelta) -->
(
{ Rhs0 = lambda_goal(PorF, EvalMethod, FixModes, NonLocals,
LambdaVars, Modes, Det, Goal0) }
@@ -1188,7 +1191,7 @@
=(ModuleInfo0),
{ instmap__pre_lambda_update(ModuleInfo0, LambdaVars, Modes,
InstMap0, InstMap) },
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap),
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap),
{ Rhs = lambda_goal(PorF, EvalMethod, FixModes, NonLocals,
LambdaVars, Modes, Det, Goal) }
;
@@ -1204,91 +1207,96 @@
recompute_instmap_delta_2(_, pragma_c_code(A, PredId, ProcId, Args, E, F,
G), _, pragma_c_code(A, PredId, ProcId, Args, E, F, G),
- InstMap, InstMapDelta) -->
+ _VarTypes, InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Args, InstMap, InstMapDelta).
%-----------------------------------------------------------------------------%
:- pred recompute_instmap_delta_conj(bool, list(hlds_goal), list(hlds_goal),
- instmap, instmap_delta, module_info, module_info).
-:- mode recompute_instmap_delta_conj(in, in, out, in, out, in, out) is det.
+ vartypes, instmap, instmap_delta, module_info, module_info).
+:- mode recompute_instmap_delta_conj(in, in, out, in, in, out, in, out) is det.
-recompute_instmap_delta_conj(_, [], [], _InstMap, InstMapDelta) -->
+recompute_instmap_delta_conj(_, [], [], _VarTypes, _InstMap, InstMapDelta) -->
{ instmap_delta_init_reachable(InstMapDelta) }.
recompute_instmap_delta_conj(Atomic, [Goal0 | Goals0], [Goal | Goals],
- InstMap0, InstMapDelta) -->
+ VarTypes, InstMap0, InstMapDelta) -->
recompute_instmap_delta(Atomic, Goal0, Goal,
- InstMap0, InstMapDelta0),
+ VarTypes, InstMap0, InstMapDelta0),
{ instmap__apply_instmap_delta(InstMap0, InstMapDelta0, InstMap1) },
recompute_instmap_delta_conj(Atomic, Goals0, Goals,
- InstMap1, InstMapDelta1),
+ VarTypes, InstMap1, InstMapDelta1),
{ instmap_delta_apply_instmap_delta(InstMapDelta0, InstMapDelta1,
InstMapDelta) }.
%-----------------------------------------------------------------------------%
:- pred recompute_instmap_delta_disj(bool, list(hlds_goal), list(hlds_goal),
- instmap, set(prog_var), instmap_delta,
+ vartypes, instmap, set(prog_var), instmap_delta,
module_info, module_info).
-:- mode recompute_instmap_delta_disj(in, in, out, in, in, out, in, out) is det.
+:- mode recompute_instmap_delta_disj(in, in, out, in, in, in, out, in, out)
+ is det.
-recompute_instmap_delta_disj(_, [], [], _, _, InstMapDelta) -->
+recompute_instmap_delta_disj(_, [], [], _, _, _, InstMapDelta) -->
{ instmap_delta_init_unreachable(InstMapDelta) }.
recompute_instmap_delta_disj(Atomic, [Goal0], [Goal],
- InstMap, _, InstMapDelta) -->
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap, InstMapDelta).
+ VarTypes, InstMap, _, InstMapDelta) -->
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap,
+ InstMapDelta).
recompute_instmap_delta_disj(Atomic, [Goal0 | Goals0], [Goal | Goals],
- InstMap, NonLocals, InstMapDelta) -->
+ VarTypes, InstMap, NonLocals, InstMapDelta) -->
{ Goals0 = [_|_] },
recompute_instmap_delta(Atomic, Goal0, Goal,
- InstMap, InstMapDelta0),
+ VarTypes, InstMap, InstMapDelta0),
recompute_instmap_delta_disj(Atomic, Goals0, Goals,
- InstMap, NonLocals, InstMapDelta1),
+ VarTypes, InstMap, NonLocals, InstMapDelta1),
merge_instmap_delta(InstMap, NonLocals, InstMapDelta0,
InstMapDelta1, InstMapDelta).
:- pred recompute_instmap_delta_par_conj(bool, list(hlds_goal),
- list(hlds_goal), instmap, set(prog_var), instmap_delta,
- module_info, module_info).
-:- mode recompute_instmap_delta_par_conj(in, in, out, in, in, out,
+ list(hlds_goal), vartypes, instmap, set(prog_var),
+ instmap_delta, module_info, module_info).
+:- mode recompute_instmap_delta_par_conj(in, in, out, in, in, in, out,
in, out) is det.
-recompute_instmap_delta_par_conj(_, [], [], _, _, InstMapDelta) -->
+recompute_instmap_delta_par_conj(_, [], [], _, _, _, InstMapDelta) -->
{ instmap_delta_init_unreachable(InstMapDelta) }.
recompute_instmap_delta_par_conj(Atomic, [Goal0], [Goal],
- InstMap, _, InstMapDelta) -->
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap, InstMapDelta).
+ VarTypes, InstMap, _, InstMapDelta) -->
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap,
+ InstMapDelta).
recompute_instmap_delta_par_conj(Atomic, [Goal0 | Goals0], [Goal | Goals],
- InstMap, NonLocals, InstMapDelta) -->
+ VarTypes, InstMap, NonLocals, InstMapDelta) -->
{ Goals0 = [_|_] },
recompute_instmap_delta(Atomic, Goal0, Goal,
- InstMap, InstMapDelta0),
+ VarTypes, InstMap, InstMapDelta0),
recompute_instmap_delta_par_conj(Atomic, Goals0, Goals,
- InstMap, NonLocals, InstMapDelta1),
+ VarTypes, InstMap, NonLocals, InstMapDelta1),
unify_instmap_delta(InstMap, NonLocals, InstMapDelta0,
InstMapDelta1, InstMapDelta).
%-----------------------------------------------------------------------------%
:- pred recompute_instmap_delta_cases(bool, prog_var, list(case), list(case),
- instmap, set(prog_var), instmap_delta,
+ vartypes, instmap, set(prog_var), instmap_delta,
module_info, module_info).
:- mode recompute_instmap_delta_cases(in, in, in, out,
- in, in, out, in, out) is det.
+ in, in, in, out, in, out) is det.
-recompute_instmap_delta_cases(_, _, [], [], _, _, InstMapDelta) -->
+recompute_instmap_delta_cases(_, _, [], [], _, _, _, InstMapDelta) -->
{ instmap_delta_init_unreachable(InstMapDelta) }.
recompute_instmap_delta_cases(Atomic, Var, [Case0 | Cases0], [Case | Cases],
- InstMap0, NonLocals, InstMapDelta) -->
+ VarTypes, InstMap0, NonLocals, InstMapDelta) -->
{ Case0 = case(Functor, Goal0) },
- instmap__bind_var_to_functor(Var, Functor, InstMap0, InstMap),
- recompute_instmap_delta(Atomic, Goal0, Goal, InstMap, InstMapDelta0),
- instmap_delta_bind_var_to_functor(Var, Functor,
+ { map__lookup(VarTypes, Var, Type) },
+ instmap__bind_var_to_functor(Var, Type, Functor, InstMap0, InstMap),
+ recompute_instmap_delta(Atomic, Goal0, Goal, VarTypes, InstMap,
+ InstMapDelta0),
+ instmap_delta_bind_var_to_functor(Var, Type, Functor,
InstMap0, InstMapDelta0, InstMapDelta1),
{ Case = case(Functor, Goal) },
recompute_instmap_delta_cases(Atomic, Var, Cases0, Cases,
- InstMap0, NonLocals, InstMapDelta2),
+ VarTypes, InstMap0, NonLocals, InstMapDelta2),
merge_instmap_delta(InstMap0, NonLocals, InstMapDelta1,
InstMapDelta2, InstMapDelta).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.232
diff -u -r1.232 modes.m
--- compiler/modes.m 1999/07/13 08:53:16 1.232
+++ compiler/modes.m 1999/10/14 16:14:55
@@ -186,7 +186,7 @@
% The following predicates are used by unique_modes.m.
-:- import_module mode_info.
+:- import_module mode_info, hlds_data.
% Modecheck a unification.
@@ -251,6 +251,14 @@
mode_info).
:- mode mode_info_remove_goals_live_vars(in, mode_info_di, mode_info_uo) is det.
+ % modecheck_functor_test(ConsId, Var):
+ % update the instmap to reflect the fact that
+ % Var was bound to ConsId.
+ % This is used for the functor tests in `switch' statements.
+ %
+:- pred modecheck_functor_test(prog_var, cons_id, mode_info, mode_info).
+:- mode modecheck_functor_test(in, in, mode_info_di, mode_info_uo) is det.
+
%-----------------------------------------------------------------------------%
% The following predicates are used by modecheck_unify.m.
@@ -1606,14 +1614,11 @@
{ Case = case(ConsId, Goal) },
mode_info_dcg_get_instmap(InstMap0),
- % record the fact that Var was bound to ConsId in the
- % instmap before processing this case
- { cons_id_arity(ConsId, Arity) },
- { list__duplicate(Arity, free, ArgInsts) },
- modecheck_set_var_inst(Var,
- bound(unique, [functor(ConsId, ArgInsts)])),
+ % record the fact that Var was bound to ConsId in the
+ % instmap before processing this case
+ modecheck_functor_test(Var, ConsId),
- % modecheck this case (if it is reachable)
+ % modecheck this case (if it is reachable)
mode_info_dcg_get_instmap(InstMap1),
( { instmap__is_reachable(InstMap1) } ->
modecheck_goal(Goal0, Goal1),
@@ -1631,6 +1636,26 @@
mode_info_set_instmap(InstMap0),
modecheck_case_list(Cases0, Var, Cases, InstMaps).
+
+ % modecheck_functor_test(ConsId, Var):
+ % update the instmap to reflect the fact that
+ % Var was bound to ConsId.
+ % This is used for the functor tests in `switch' statements.
+ %
+modecheck_functor_test(Var, ConsId) -->
+ % figure out the arity of this constructor,
+ % _including_ any type-infos or typeclass-infos
+ % inserted for existential data types.
+ =(ModeInfo0),
+ { mode_info_get_module_info(ModeInfo0, ModuleInfo) },
+ { mode_info_get_var_types(ModeInfo0, VarTypes) },
+ { map__lookup(VarTypes, Var, Type) },
+ { AdjustedArity = cons_id_adjusted_arity(ModuleInfo, Type, ConsId) },
+
+ % record the fact that Var was bound to ConsId in the instmap
+ { list__duplicate(AdjustedArity, free, ArgInsts) },
+ modecheck_set_var_inst(Var,
+ bound(unique, [functor(ConsId, ArgInsts)])).
%-----------------------------------------------------------------------------%
Index: compiler/pd_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_info.m,v
retrieving revision 1.5
diff -u -r1.5 pd_info.m
--- compiler/pd_info.m 1999/06/01 09:44:12 1.5
+++ compiler/pd_info.m 1999/10/11 15:24:56
@@ -269,7 +269,10 @@
pd_info_bind_var_to_functor(Var, ConsId) -->
pd_info_get_instmap(InstMap0),
pd_info_get_module_info(ModuleInfo0),
- { instmap__bind_var_to_functor(Var, ConsId, InstMap0, InstMap,
+ pd_info_get_proc_info(ProcInfo),
+ { proc_info_vartypes(ProcInfo, VarTypes) },
+ { map__lookup(VarTypes, Var, Type) },
+ { instmap__bind_var_to_functor(Var, Type, ConsId, InstMap0, InstMap,
ModuleInfo0, ModuleInfo) },
pd_info_set_instmap(InstMap),
pd_info_set_module_info(ModuleInfo).
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.6
diff -u -r1.6 pd_util.m
--- compiler/pd_util.m 1999/07/13 08:53:19 1.6
+++ compiler/pd_util.m 1999/10/14 16:00:24
@@ -103,7 +103,7 @@
% only conj, some, not and atomic goals, since deforest.m
% only attempts to optimize those types of conjunctions.
:- pred pd_util__goals_match(module_info::in, hlds_goal::in, list(prog_var)::in,
- list(type)::in, hlds_goal::in, map(prog_var, type)::in,
+ list(type)::in, hlds_goal::in, vartypes::in,
map(prog_var, prog_var)::out, tsubst::out) is semidet.
% pd_util__can_reorder_goals(ModuleInfo, FullyStrict, Goal1, Goal2).
@@ -304,13 +304,14 @@
pd_util__get_branch_vars_proc(PredProcId, ProcInfo,
Info0, Info, ModuleInfo0, ModuleInfo) :-
proc_info_goal(ProcInfo, Goal),
+ proc_info_vartypes(ProcInfo, VarTypes),
instmap__init_reachable(InstMap0),
map__init(Vars0),
set__init(LeftVars0),
goal_to_conj_list(Goal, GoalList),
(
pd_util__get_branch_vars_goal_2(ModuleInfo0, GoalList, no,
- InstMap0, LeftVars0, LeftVars, Vars0, Vars)
+ VarTypes, InstMap0, LeftVars0, LeftVars, Vars0, Vars)
->
proc_info_headvars(ProcInfo, HeadVars),
map__init(ThisProcArgMap0),
@@ -326,7 +327,7 @@
% Look for opportunities for deforestation in
% the sub-branches of the top-level goal.
pd_util__get_sub_branch_vars_goal(ModuleInfo0, Info1,
- GoalList, InstMap0, Vars, AllVars, ModuleInfo),
+ GoalList, VarTypes, InstMap0, Vars, AllVars, ModuleInfo),
pd_util__get_extra_info_headvars(HeadVars, 1, LeftVars0,
AllVars, ThisProcArgMap0, ThisProcArgMap,
ThisProcLeftArgs0, _),
@@ -399,14 +400,16 @@
pd_info_get_module_info(ModuleInfo0),
pd_info_get_instmap(InstMap0),
pd_info_get_proc_arg_info(ProcArgInfo),
+ pd_info_get_proc_info(ProcInfo),
+ { proc_info_vartypes(ProcInfo, VarTypes) },
{ set__init(LeftVars0) },
{ map__init(Vars0) },
(
{ pd_util__get_branch_vars_goal_2(ModuleInfo0, [Goal], no,
- InstMap0, LeftVars0, LeftVars, Vars0, Vars1) }
+ VarTypes, InstMap0, LeftVars0, LeftVars, Vars0, Vars1) }
->
{ pd_util__get_sub_branch_vars_goal(ModuleInfo0, ProcArgInfo,
- [Goal], InstMap0, Vars1, Vars, ModuleInfo) },
+ [Goal], VarTypes, InstMap0, Vars1, Vars, ModuleInfo) },
pd_info_set_module_info(ModuleInfo),
% OpaqueVars is only filled in for calls.
@@ -419,12 +422,13 @@
).
:- pred pd_util__get_branch_vars_goal_2(module_info::in, list(hlds_goal)::in,
- bool::in, instmap::in, set(prog_var)::in, set(prog_var)::out,
+ bool::in, vartypes::in, instmap::in,
+ set(prog_var)::in, set(prog_var)::out,
pd_var_info::in, pd_var_info::out) is semidet.
-pd_util__get_branch_vars_goal_2(_, [], yes, _, LeftVars, LeftVars, Vars, Vars).
+pd_util__get_branch_vars_goal_2(_, [], yes, _, _, LeftVars, LeftVars, Vars, Vars).
pd_util__get_branch_vars_goal_2(ModuleInfo, [Goal | Goals], FoundBranch0,
- InstMap0, LeftVars0, LeftVars, Vars0, Vars) :-
+ VarTypes, InstMap0, LeftVars0, LeftVars, Vars0, Vars) :-
Goal = _ - GoalInfo,
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
@@ -433,8 +437,8 @@
% since deforestation of goals with more than one is
% likely to be less productive.
FoundBranch0 = no,
- pd_util__get_branch_vars(ModuleInfo, Goal, InstMapDeltas,
- InstMap, 1, Vars0, Vars1),
+ pd_util__get_branch_vars(ModuleInfo, Goal,
+ InstMapDeltas, InstMap, 1, Vars0, Vars1),
pd_util__get_left_vars(Goal, LeftVars0, LeftVars1),
FoundBranch = yes
;
@@ -445,7 +449,7 @@
LeftVars1 = LeftVars0
),
pd_util__get_branch_vars_goal_2(ModuleInfo, Goals, FoundBranch,
- InstMap, LeftVars1, LeftVars, Vars1, Vars).
+ VarTypes, InstMap, LeftVars1, LeftVars, Vars1, Vars).
:- pred pd_util__get_branch_instmap_deltas(hlds_goal::in,
list(instmap_delta)::out) is semidet.
@@ -536,13 +540,13 @@
% Look at the goals in the branches for extra information.
:- pred pd_util__get_sub_branch_vars_goal(module_info::in, pd_arg_info::in,
- list(hlds_goal)::in, instmap::in,
+ list(hlds_goal)::in, vartypes::in, instmap::in,
branch_info_map(prog_var)::in, branch_info_map(prog_var)::out,
module_info::out) is det.
-pd_util__get_sub_branch_vars_goal(Module, _, [], _, Vars, Vars, Module).
+pd_util__get_sub_branch_vars_goal(Module, _, [], _, _, Vars, Vars, Module).
pd_util__get_sub_branch_vars_goal(ModuleInfo0, ProcArgInfo, [Goal | GoalList],
- InstMap0, Vars0, SubVars, ModuleInfo) :-
+ VarTypes, InstMap0, Vars0, SubVars, ModuleInfo) :-
Goal = GoalExpr - GoalInfo,
( GoalExpr = if_then_else(_, Cond, Then, Else, _) ->
Cond = _ - CondInfo,
@@ -550,18 +554,18 @@
instmap__apply_instmap_delta(InstMap0, CondDelta, InstMap1),
goal_to_conj_list(Then, ThenList),
pd_util__examine_branch(ModuleInfo0, ProcArgInfo, 1, ThenList,
- InstMap1, Vars0, Vars1),
+ VarTypes, InstMap1, Vars0, Vars1),
goal_to_conj_list(Else, ElseList),
pd_util__examine_branch(ModuleInfo0, ProcArgInfo, 2, ElseList,
- InstMap0, Vars1, Vars2),
+ VarTypes, InstMap0, Vars1, Vars2),
ModuleInfo1 = ModuleInfo0
; GoalExpr = disj(Goals, _) ->
pd_util__examine_branch_list(ModuleInfo0, ProcArgInfo,
- 1, Goals, InstMap0, Vars0, Vars2),
+ 1, Goals, VarTypes, InstMap0, Vars0, Vars2),
ModuleInfo1 = ModuleInfo0
; GoalExpr = switch(Var, _, Cases, _) ->
pd_util__examine_case_list(ModuleInfo0, ProcArgInfo, 1, Var,
- Cases, InstMap0, Vars0, Vars2, ModuleInfo1)
+ Cases, VarTypes, InstMap0, Vars0, Vars2, ModuleInfo1)
;
ModuleInfo1 = ModuleInfo0,
Vars2 = Vars0
@@ -569,48 +573,49 @@
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
pd_util__get_sub_branch_vars_goal(ModuleInfo1, ProcArgInfo, GoalList,
- InstMap, Vars2, SubVars, ModuleInfo).
+ VarTypes, InstMap, Vars2, SubVars, ModuleInfo).
:- pred pd_util__examine_branch_list(module_info::in, pd_arg_info::in, int::in,
- list(hlds_goal)::in, instmap::in, branch_info_map(prog_var)::in,
- branch_info_map(prog_var)::out) is det.
+ list(hlds_goal)::in, vartypes::in, instmap::in,
+ branch_info_map(prog_var)::in, branch_info_map(prog_var)::out) is det.
-pd_util__examine_branch_list(_, _, _, [], _, Vars, Vars).
+pd_util__examine_branch_list(_, _, _, [], _, _, Vars, Vars).
pd_util__examine_branch_list(ModuleInfo, ProcArgInfo, BranchNo, [Goal | Goals],
- InstMap, Vars0, Vars) :-
+ VarTypes, InstMap, Vars0, Vars) :-
goal_to_conj_list(Goal, GoalList),
pd_util__examine_branch(ModuleInfo, ProcArgInfo, BranchNo, GoalList,
- InstMap, Vars0, Vars1),
+ VarTypes, InstMap, Vars0, Vars1),
NextBranch is BranchNo + 1,
pd_util__examine_branch_list(ModuleInfo, ProcArgInfo, NextBranch,
- Goals, InstMap, Vars1, Vars).
+ Goals, VarTypes, InstMap, Vars1, Vars).
:- pred pd_util__examine_case_list(module_info::in, pd_arg_info::in, int::in,
- prog_var::in, list(case)::in, instmap::in,
+ prog_var::in, list(case)::in, vartypes::in, instmap::in,
branch_info_map(prog_var)::in,
branch_info_map(prog_var)::out, module_info::out) is det.
-pd_util__examine_case_list(Module, _, _, _, [], _, Vars, Vars, Module).
+pd_util__examine_case_list(Module, _, _, _, [], _, _, Vars, Vars, Module).
pd_util__examine_case_list(ModuleInfo0, ProcArgInfo, BranchNo, Var,
- [case(ConsId, Goal) | Goals], InstMap,
+ [case(ConsId, Goal) | Goals], VarTypes, InstMap,
Vars0, Vars, ModuleInfo) :-
- instmap__bind_var_to_functor(Var, ConsId, InstMap, InstMap1,
+ map__lookup(VarTypes, Var, Type),
+ instmap__bind_var_to_functor(Var, Type, ConsId, InstMap, InstMap1,
ModuleInfo0, ModuleInfo1),
goal_to_conj_list(Goal, GoalList),
pd_util__examine_branch(ModuleInfo1, ProcArgInfo, BranchNo, GoalList,
- InstMap1, Vars0, Vars1),
+ VarTypes, InstMap1, Vars0, Vars1),
NextBranch is BranchNo + 1,
pd_util__examine_case_list(ModuleInfo1, ProcArgInfo, NextBranch,
- Var, Goals, InstMap, Vars1, Vars, ModuleInfo).
+ Var, Goals, VarTypes, InstMap, Vars1, Vars, ModuleInfo).
:- pred pd_util__examine_branch(module_info::in, pd_arg_info::in, int::in,
- list(hlds_goal)::in, instmap::in,
+ list(hlds_goal)::in, vartypes::in, instmap::in,
branch_info_map(prog_var)::in, branch_info_map(prog_var)::out)
is det.
-pd_util__examine_branch(_, _, _, [], _, Vars, Vars).
+pd_util__examine_branch(_, _, _, [], _, _, Vars, Vars).
pd_util__examine_branch(ModuleInfo, ProcArgInfo, BranchNo,
- [Goal | Goals], InstMap, Vars0, Vars) :-
+ [Goal | Goals], VarTypes, InstMap, Vars0, Vars) :-
( Goal = call(PredId, ProcId, Args, _, _, _) - _ ->
(
map__search(ProcArgInfo, proc(PredId, ProcId),
@@ -628,7 +633,7 @@
set__init(LeftVars0),
map__init(Vars1),
pd_util__get_branch_vars_goal_2(ModuleInfo, [Goal], no,
- InstMap, LeftVars0, _, Vars1, Vars2)
+ VarTypes, InstMap, LeftVars0, _, Vars1, Vars2)
->
map__keys(Vars2, ExtraVars2),
combine_vars(Vars0, BranchNo, ExtraVars2, Vars3)
@@ -639,7 +644,7 @@
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap, InstMapDelta, InstMap1),
pd_util__examine_branch(ModuleInfo, ProcArgInfo, BranchNo,
- Goals, InstMap1, Vars3, Vars).
+ Goals, VarTypes, InstMap1, Vars3, Vars).
:- pred combine_vars(branch_info_map(prog_var)::in, int::in, list(prog_var)::in,
branch_info_map(prog_var)::out) is det.
@@ -670,7 +675,9 @@
pd_util__recompute_instmap_delta(Goal0, Goal) -->
pd_info_get_module_info(ModuleInfo0),
pd_info_get_instmap(InstMap),
- { recompute_instmap_delta(yes, Goal0, Goal, InstMap,
+ pd_info_get_proc_info(ProcInfo),
+ { proc_info_vartypes(ProcInfo, VarTypes) },
+ { recompute_instmap_delta(yes, Goal0, Goal, VarTypes, InstMap,
ModuleInfo0, ModuleInfo) },
pd_info_set_module_info(ModuleInfo).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.172
diff -u -r1.172 polymorphism.m
--- compiler/polymorphism.m 1999/10/03 04:15:24 1.172
+++ compiler/polymorphism.m 1999/10/11 10:22:30
@@ -1864,22 +1864,6 @@
%-----------------------------------------------------------------------------%
-% constraint_list_get_tvars(Constraints, TVars):
-% return the list of type variables contained in a list of constraints
-
-:- pred constraint_list_get_tvars(list(class_constraint), list(tvar)).
-:- mode constraint_list_get_tvars(in, out) is det.
-constraint_list_get_tvars(Constraints, TVars) :-
- list__map(constraint_get_tvars, Constraints, TVarsList),
- list__condense(TVarsList, TVars).
-
-:- pred constraint_get_tvars(class_constraint, list(tvar)).
-:- mode constraint_get_tvars(in, out) is det.
-constraint_get_tvars(constraint(_Name, Args), TVars) :-
- term__vars_list(Args, TVars).
-
-%-----------------------------------------------------------------------------%
-
:- pred polymorphism__fixup_quantification(list(prog_var), existq_tvars,
hlds_goal, hlds_goal, poly_info, poly_info).
:- mode polymorphism__fixup_quantification(in, in, in, out, in, out) is det.
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.20
diff -u -r1.20 saved_vars.m
--- compiler/saved_vars.m 1999/08/25 06:10:12 1.20
+++ compiler/saved_vars.m 1999/10/14 15:54:14
@@ -71,7 +71,7 @@
implicitly_quantify_clause_body(HeadVars, Goal1, Varset1,
VarTypes1, Goal2, Varset, VarTypes, _Warnings),
proc_info_get_initial_instmap(ProcInfo0, ModuleInfo0, InstMap0),
- recompute_instmap_delta(no, Goal2, Goal, InstMap0,
+ recompute_instmap_delta(no, Goal2, Goal, VarTypes, InstMap0,
ModuleInfo0, ModuleInfo),
% hlds_out__write_goal(Goal, ModuleInfo, Varset, 0, "\n"),
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.71
diff -u -r1.71 simplify.m
--- compiler/simplify.m 1999/10/03 04:15:25 1.71
+++ compiler/simplify.m 1999/10/14 15:54:42
@@ -223,7 +223,7 @@
simplify_info_get_module_info(Info3, ModuleInfo3),
recompute_instmap_delta(RecomputeAtomic, Goal2, Goal3,
- InstMap0, ModuleInfo3, ModuleInfo4),
+ VarTypes, InstMap0, ModuleInfo3, ModuleInfo4),
simplify_info_set_module_info(Info3, ModuleInfo4, Info4)
;
Goal3 = Goal1,
@@ -587,7 +587,9 @@
set__insert(NonLocals0, Var, NonLocals),
goal_info_get_instmap_delta(GoalInfo0, InstMapDelta0),
simplify_info_get_instmap(Info2, InstMap),
- instmap_delta_bind_var_to_functor(Var, ConsId,
+ simplify_info_get_var_types(Info2, VarTypes),
+ map__lookup(VarTypes, Var, Type),
+ instmap_delta_bind_var_to_functor(Var, Type, ConsId,
InstMap, InstMapDelta0, InstMapDelta,
ModuleInfo0, ModuleInfo),
simplify_info_set_module_info(Info2,
@@ -1498,7 +1500,9 @@
simplify_info_get_instmap(Info0, InstMap0),
Case0 = case(ConsId, Goal0),
simplify_info_get_module_info(Info1, ModuleInfo0),
- instmap__bind_var_to_functor(Var, ConsId,
+ simplify_info_get_var_types(Info1, VarTypes),
+ map__lookup(VarTypes, Var, Type),
+ instmap__bind_var_to_functor(Var, Type, ConsId,
InstMap0, InstMap1, ModuleInfo0, ModuleInfo1),
simplify_info_set_module_info(Info1, ModuleInfo1, Info2),
simplify_info_set_instmap(Info2, InstMap1, Info3),
@@ -1524,7 +1528,7 @@
%
goal_info_get_instmap_delta(GoalInfo, InstMapDelta0),
simplify_info_get_module_info(Info4, ModuleInfo5),
- instmap_delta_bind_var_to_functor(Var, ConsId,
+ instmap_delta_bind_var_to_functor(Var, Type, ConsId,
InstMap0, InstMapDelta0, InstMapDelta,
ModuleInfo5, ModuleInfo),
simplify_info_set_module_info(Info4, ModuleInfo, Info5),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.73
diff -u -r1.73 type_util.m
--- compiler/type_util.m 1999/10/03 04:15:26 1.73
+++ compiler/type_util.m 1999/10/14 16:21:15
@@ -314,11 +314,31 @@
:- pred strip_prog_contexts(list(term(T))::in, list(term(T))::out) is det.
:- pred strip_prog_context(term(T)::in, term(T)::out) is det.
+ % cons_id_adjusted_arity(ModuleInfo, Type, ConsId):
+ % Returns the number of arguments of specified constructor id,
+ % adjusted to include the extra typeclassinfo and typeinfo
+ % arguments inserted by polymorphism.m for existentially
+ % typed constructors.
+ %
+:- func cons_id_adjusted_arity(module_info, type, cons_id) = int.
+
+ % constraint_list_get_tvars(Constraints, TVars):
+ % return the list of type variables contained in a
+ % list of constraints
+ %
+:- pred constraint_list_get_tvars(list(class_constraint), list(tvar)).
+:- mode constraint_list_get_tvars(in, out) is det.
+
+ % constraint_list_get_tvars(Constraint, TVars):
+ % return the list of type variables contained in a constraint.
+:- pred constraint_get_tvars(class_constraint, list(tvar)).
+:- mode constraint_get_tvars(in, out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module bool, require, std_util, string.
+:- import_module bool, int, require, std_util, string.
:- import_module prog_io, prog_io_goal, prog_util.
type_util__type_id_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -1191,4 +1211,35 @@
strip_prog_contexts(As0, As).
%-----------------------------------------------------------------------------%
+
+cons_id_adjusted_arity(ModuleInfo, Type, ConsId) = AdjustedArity :-
+ % figure out the arity of this constructor,
+ % _including_ any type-infos or typeclass-infos
+ % inserted for existential data types.
+ cons_id_arity(ConsId, ConsArity),
+ (
+ type_util__get_existq_cons_defn(ModuleInfo, Type, ConsId,
+ ConsDefn)
+ ->
+ ConsDefn = ctor_defn(_TVarSet, ExistQTVars, Constraints,
+ _ArgTypes, _ResultType),
+ list__length(Constraints, NumTypeClassInfos),
+ constraint_list_get_tvars(Constraints, ConstrainedTVars),
+ list__delete_elems(ExistQTVars, ConstrainedTVars,
+ UnconstrainedExistQTVars),
+ list__length(UnconstrainedExistQTVars, NumTypeInfos),
+ AdjustedArity = ConsArity + NumTypeClassInfos + NumTypeInfos
+ ;
+ AdjustedArity = ConsArity
+ ).
+
+%-----------------------------------------------------------------------------%
+
+constraint_list_get_tvars(Constraints, TVars) :-
+ list__map(constraint_get_tvars, Constraints, TVarsList),
+ list__condense(TVarsList, TVars).
+
+constraint_get_tvars(constraint(_Name, Args), TVars) :-
+ term__vars_list(Args, TVars).
+
%-----------------------------------------------------------------------------%
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.57
diff -u -r1.57 unique_modes.m
--- compiler/unique_modes.m 1999/08/30 04:57:53 1.57
+++ compiler/unique_modes.m 1999/10/11 09:31:06
@@ -777,14 +777,12 @@
[Case | Cases], [InstMap | InstMaps]) -->
{ Case0 = case(ConsId, Goal0) },
{ Case = case(ConsId, Goal) },
- mode_info_dcg_get_instmap(InstMap0),
+ =(ModeInfo0),
+ { mode_info_get_instmap(ModeInfo0, InstMap0) },
- % record the fact that Var was bound to ConsId in the
- % instmap before processing this case
- { cons_id_arity(ConsId, Arity) },
- { list__duplicate(Arity, free, ArgInsts) },
- modecheck_set_var_inst(Var,
- bound(unique, [functor(ConsId, ArgInsts)])),
+ % record the fact that Var was bound to ConsId in the
+ % instmap before processing this case
+ modecheck_functor_test(Var, ConsId),
mode_info_dcg_get_instmap(InstMap1),
( { instmap__is_reachable(InstMap1) } ->
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.65
diff -u -r1.65 Mmakefile
--- tests/hard_coded/Mmakefile 1999/09/30 08:55:49 1.65
+++ tests/hard_coded/Mmakefile 1999/10/14 17:38:40
@@ -33,6 +33,8 @@
elim_special_pred \
existential_bound_tvar \
existential_reordering \
+ existential_type_switch \
+ existential_types_test \
eqv_type_bug \
error_func \
erroneous_liveness \
@@ -116,6 +118,7 @@
MCFLAGS-nondet_ctrl_vn = --optimize-value-number
MCFLAGS-rnd = -O6
MCFLAGS-type_spec = --user-guided-type-specialization
+MCFLAGS-existential_types_test = --infer-all
# In grade `none' with options `-O1 --opt-space' on kryten
# (a sparc-sun-solaris2.5 system), mode_choice needs to be linked
cvs diff: tests/hard_coded/existential_type_switch.exp is a new entry, no comparison available
cvs diff: tests/hard_coded/existential_type_switch.m is a new entry, no comparison available
New file: tests/hard_coded/existential_type_switch.exp
r succeeded, Z = 42
New file: tests/hard_coded/existential_type_switch.m
% Regression test: rotd-1999-10-12 did not handle switches on existential
% data types.
%------------------------------------------------------------------------------%
:- module existential_type_switch.
:- interface.
:- import_module io.
:- pred main(state::di, state::uo) is det.
:- typeclass tc(TC) where [
pred r(TC, int),
mode r(in, out) is semidet
].
:- type maybe
---> no
; some [T] (yes(T) => tc(T)).
:- pred p(maybe).
:- mode p(out) is det.
%------------------------------------------------------------------------------%
:- implementation.
:- import_module int.
main -->
{ p(X) },
( { X = yes(Y) },
(if { r(Y, Z) } then
print("r succeeded, Z = "), print(Z), nl
else
print("r failed"), nl
)
;
{ X = no },
print("no"), nl
).
p(X) :-
(
q(1, Y)
->
X = 'new yes'(Y)
;
X = no
).
:- some [T2] pred q(int::in, T2::out) is semidet => tc(T2).
q(1, 2).
%------------------------------------------------------------------------------%
:- instance tc(int) where [
pred(r/2) is s
].
:- pred s(int::in, int::out) is semidet.
s(1, 111).
s(2, 42).
%------------------------------------------------------------------------------%
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list