[m-rev.] diff: eliminate parse_tree's dependence on hlds
Zoltan Somogyi
zs at cs.mu.OZ.AU
Fri Nov 4 14:39:43 AEDT 2005
Eliminate the dependencies of submodules of parse_tree.m on type_util.m, which
is part of check_hlds.m. After this diff, submodules of parse_tree.m don't
import any HLDS modules.
At the same time, reduce dependencies of submodules of hlds.m on submodules
of check_hlds.m.
compiler/type_util.m:
compiler/prog_type.m:
compiler/prog_type_subst.m:
Move all the predicates and types that don't depend on the HLDS from
type_util.m to prog_type.m, with the exception of predicates involving
renamings and substitutions, which are moved to the new module
prog_type_subst.m.
Rename some predicates and function symbols to better reflect their
purpose.
compiler/parse_tree.m.
Add prog_type_subst.m as a submodule.
compiler/notes/compiler_design.html:
Document the new module.
compiler/hlds_pred.m:
compiler/prog_data.m:
Move the type vartypes from hlds_pred.m to prog_data.
compiler/purity.m:
compiler/prog_data.m:
Move some utility predicates that don't refer to HLDS from purity.m,
which is part of check_hlds.m, to prog_data.m.
compiler/det_analysis.m:
compiler/hlds_data.m:
compiler/prog_data.m:
Move the can_fail and soln_count types from hlds_data.m to prog_data.m,
and move utility predicates on determinisms from det_analysis.m and
hlds_data.m to prog_data.m.
compiler/typecheck.m:
compiler/hlds_module.m:
Move some predicates from typecheck.m to hlds_module.m, to avoid the
need to import typecheck.m, which is in check_hlds, in some submodules
of hlds.
compiler/*.m:
Conform to the changes above.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/accumulator.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/accumulator.m,v
retrieving revision 1.45
diff -u -b -r1.45 accumulator.m
--- compiler/accumulator.m 28 Oct 2005 02:09:56 -0000 1.45
+++ compiler/accumulator.m 1 Nov 2005 05:29:41 -0000
@@ -906,7 +906,7 @@
% goal_store, GS, and IdB is less than IdA.
%
:- pred member_lessthan_goalid(goal_store::in, goal_id::in,
- goal_id::out, goal_store__goal::out) is nondet.
+ goal_id::out, stored_goal::out) is nondet.
member_lessthan_goalid(GoalStore, N - I, N - J, Goal) :-
goal_store__member(GoalStore, N - J, Goal),
@@ -1375,7 +1375,7 @@
% Do a goal_store__lookup where the result is known to be a call.
%
:- pred lookup_call(goal_store::in, goal_id::in,
- goal_store__goal::out(call_goal)) is det.
+ stored_goal::out(call_goal)) is det.
lookup_call(GoalStore, Id, Call - InstMap) :-
goal_store__lookup(GoalStore, Id, Goal - InstMap),
Index: compiler/add_aditi.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_aditi.m,v
retrieving revision 1.5
diff -u -b -r1.5 add_aditi.m
--- compiler/add_aditi.m 28 Oct 2005 02:09:56 -0000 1.5
+++ compiler/add_aditi.m 1 Nov 2005 05:53:39 -0000
@@ -52,7 +52,6 @@
:- implementation.
-:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_out.
:- import_module hlds.make_hlds.add_clause.
@@ -64,6 +63,7 @@
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module bool.
Index: compiler/add_class.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_class.m,v
retrieving revision 1.7
diff -u -b -r1.7 add_class.m
--- compiler/add_class.m 28 Oct 2005 02:09:56 -0000 1.7
+++ compiler/add_class.m 1 Nov 2005 05:53:53 -0000
@@ -43,7 +43,6 @@
:- implementation.
:- import_module check_hlds.clause_to_proc.
-:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.make_hlds.add_clause.
@@ -56,6 +55,7 @@
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module bool.
Index: compiler/add_heap_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_heap_ops.m,v
retrieving revision 1.20
diff -u -b -r1.20 add_heap_ops.m
--- compiler/add_heap_ops.m 28 Oct 2005 02:09:56 -0000 1.20
+++ compiler/add_heap_ops.m 1 Nov 2005 07:23:40 -0000
@@ -41,7 +41,6 @@
:- implementation.
-:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.goal_form.
:- import_module hlds.goal_util.
@@ -53,6 +52,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.15
diff -u -b -r1.15 add_pragma.m
--- compiler/add_pragma.m 28 Oct 2005 02:09:57 -0000 1.15
+++ compiler/add_pragma.m 1 Nov 2005 05:54:33 -0000
@@ -130,6 +130,7 @@
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module recompilation.
:- import_module transform_hlds.term_constr_main.
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.22
diff -u -b -r1.22 add_trail_ops.m
--- compiler/add_trail_ops.m 28 Oct 2005 02:09:57 -0000 1.22
+++ compiler/add_trail_ops.m 1 Nov 2005 05:12:14 -0000
@@ -41,7 +41,6 @@
:- implementation.
-:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
@@ -52,6 +51,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/aditi_builtin_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/aditi_builtin_ops.m,v
retrieving revision 1.20
diff -u -b -r1.20 aditi_builtin_ops.m
--- compiler/aditi_builtin_ops.m 28 Oct 2005 02:09:57 -0000 1.20
+++ compiler/aditi_builtin_ops.m 1 Nov 2005 05:01:00 -0000
@@ -335,7 +335,7 @@
{ map__apply_to_list(TupleArgs0, VarTypes, TupleTypes0) },
% Remove the `aditi__state' from the list of arguments.
- { type_util__remove_aditi_state(TupleTypes0, TupleArgs0, TupleArgs) },
+ { remove_aditi_state(TupleTypes0, TupleArgs0, TupleArgs) },
%
% Produce code to create the vectors of type-infos and arguments
@@ -512,8 +512,8 @@
% Dont pass `aditi__state' arguments to Aditi -- they do not appear
% as attributes in Aditi relations.
%
- { type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
- { type_util__remove_aditi_state(ArgTypes0, HeadVars0, HeadVars) },
+ { remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
+ { remove_aditi_state(ArgTypes0, HeadVars0, HeadVars) },
%
% Generate arguments to describe the procedure to call.
@@ -682,7 +682,7 @@
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, ArgTypes0),
- type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
+ remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
rl__schema_to_string(ModuleInfo, ArgTypes, InputSchema),
UpdateProcArgs = [string(DeleteProcStr), string(InputSchema)]
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.93
diff -u -b -r1.93 bytecode_gen.m
--- compiler/bytecode_gen.m 28 Oct 2005 02:09:58 -0000 1.93
+++ compiler/bytecode_gen.m 1 Nov 2005 05:08:07 -0000
@@ -515,49 +515,49 @@
ByteInfo = byte_info(_, _, ModuleInfo, _, _),
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
TestId = int_test
;
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
TestId = char_test
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
TestId = string_test
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
TestId = float_test
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
TestId = dummy_test
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
TestId = enum_test
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
unexpected(this_file, "higher_order_type in simple_test")
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
unexpected(this_file, "tuple_type in simple_test")
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
unexpected(this_file, "user_ctor_type in simple_test")
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
unexpected(this_file, "variable_type in simple_test")
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
unexpected(this_file, "void_type in simple_test")
;
- TypeCategory = type_info_type,
+ TypeCategory = type_cat_type_info,
unexpected(this_file, "type_info_type in simple_test")
;
- TypeCategory = type_ctor_info_type,
+ TypeCategory = type_cat_type_ctor_info,
unexpected(this_file, "type_ctor_info_type in simple_test")
;
- TypeCategory = typeclass_info_type,
+ TypeCategory = type_cat_typeclass_info,
unexpected(this_file, "typeclass_info_type in simple_test")
;
- TypeCategory = base_typeclass_info_type,
+ TypeCategory = type_cat_base_typeclass_info,
unexpected(this_file, "base_typeclass_info_type in simple_test")
),
Code = node([test(ByteVar1, ByteVar2, TestId)]).
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.82
diff -u -b -r1.82 check_typeclass.m
--- compiler/check_typeclass.m 28 Oct 2005 02:09:59 -0000 1.82
+++ compiler/check_typeclass.m 1 Nov 2005 05:02:06 -0000
@@ -102,6 +102,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -688,7 +689,7 @@
apply_variable_renaming_to_type_list(SquashSubst, ArgTypes1, ArgTypes),
apply_variable_renaming_to_prog_constraints(SquashSubst,
ClassMethodClassContext1, ClassMethodClassContext),
- apply_partial_map_to_list(ExistQVars0, SquashSubst, ExistQVars),
+ apply_partial_map_to_list(SquashSubst, ExistQVars0, ExistQVars),
apply_variable_renaming_to_type_list(SquashSubst, InstanceTypes1,
InstanceTypes),
apply_variable_renaming_to_prog_constraint_list(SquashSubst,
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.57
diff -u -b -r1.57 clause_to_proc.m
--- compiler/clause_to_proc.m 28 Oct 2005 02:09:59 -0000 1.57
+++ compiler/clause_to_proc.m 1 Nov 2005 04:43:36 -0000
@@ -73,6 +73,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.65
diff -u -b -r1.65 constraint.m
--- compiler/constraint.m 28 Oct 2005 02:10:01 -0000 1.65
+++ compiler/constraint.m 1 Nov 2005 04:02:15 -0000
@@ -22,7 +22,6 @@
:- interface.
:- import_module hlds.hlds_goal.
-:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_module.
:- import_module hlds.instmap.
:- import_module parse_tree.prog_data.
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.90
diff -u -b -r1.90 cse_detection.m
--- compiler/cse_detection.m 28 Oct 2005 02:10:02 -0000 1.90
+++ compiler/cse_detection.m 1 Nov 2005 04:43:50 -0000
@@ -54,6 +54,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.54
diff -u -b -r1.54 deforest.m
--- compiler/deforest.m 28 Oct 2005 02:10:02 -0000 1.54
+++ compiler/deforest.m 1 Nov 2005 05:29:51 -0000
@@ -70,7 +70,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_out.
-:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.dependency_graph.
:- import_module transform_hlds.inlining.
Index: compiler/dense_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dense_switch.m,v
retrieving revision 1.54
diff -u -b -r1.54 dense_switch.m
--- compiler/dense_switch.m 28 Oct 2005 02:10:03 -0000 1.54
+++ compiler/dense_switch.m 1 Nov 2005 10:19:59 -0000
@@ -19,13 +19,12 @@
:- interface.
:- import_module backend_libs.switch_util.
-:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module ll_backend.code_info.
:- import_module ll_backend.llds.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
% Should this switch be implemented as a dense jump table?
% If so, we return the starting and ending values for the table,
@@ -57,6 +56,8 @@
:- implementation.
:- import_module backend_libs.builtin_ops.
+:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_module.
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.181
diff -u -b -r1.181 det_analysis.m
--- compiler/det_analysis.m 28 Oct 2005 02:10:03 -0000 1.181
+++ compiler/det_analysis.m 1 Nov 2005 10:06:57 -0000
@@ -54,7 +54,6 @@
:- import_module check_hlds.det_report.
:- import_module check_hlds.det_util.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
@@ -64,7 +63,6 @@
:- import_module io.
:- import_module list.
-:- import_module std_util.
% Perform determinism inference for local predicates with no determinism
% declarations, and determinism checking for all other predicates.
@@ -100,31 +98,6 @@
---> all_solns
; first_soln.
- % The following predicates implement the tables for computing the
- % determinism of compound goals from the determinism of their components.
-
-:- pred det_conjunction_detism(determinism::in, determinism::in,
- determinism::out) is det.
-
-:- pred det_par_conjunction_detism(determinism::in, determinism::in,
- determinism::out) is det.
-
-:- pred det_switch_detism(determinism::in, determinism::in, determinism::out)
- is det.
-
-:- pred det_disjunction_maxsoln(soln_count::in, soln_count::in,
- soln_count::out) is det.
-
-:- pred det_disjunction_canfail(can_fail::in, can_fail::in, can_fail::out)
- is det.
-
-:- pred det_switch_maxsoln(soln_count::in, soln_count::in, soln_count::out)
- is det.
-
-:- pred det_switch_canfail(can_fail::in, can_fail::in, can_fail::out) is det.
-
-:- pred det_negation_det(determinism::in, maybe(determinism)::out) is det.
-
%-----------------------------------------------------------------------------%
:- implementation.
@@ -141,6 +114,7 @@
:- import_module libs.options.
:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_out.
:- import_module assoc_list.
@@ -148,6 +122,7 @@
:- import_module map.
:- import_module require.
:- import_module set.
+:- import_module std_util.
:- import_module string.
:- import_module term.
@@ -1194,146 +1169,6 @@
;
SolnContext = all_solns
).
-
-det_conjunction_detism(DetismA, DetismB, Detism) :-
- % When figuring out the determinism of a conjunction, if the second goal
- % is unreachable, then then the determinism of the conjunction is just
- % the determinism of the first goal.
-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- ( MaxSolnA = at_most_zero ->
- Detism = DetismA
- ;
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_conjunction_canfail(CanFailA, CanFailB, CanFail),
- det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln)
- ).
-
-det_par_conjunction_detism(DetismA, DetismB, Detism) :-
- % Figuring out the determinism of a parallel conjunction is much easier
- % than for a sequential conjunction, since you simply ignore the case
- % where the second goal is unreachable. Just do a normal solution count.
-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_conjunction_canfail(CanFailA, CanFailB, CanFail),
- det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln).
-
-det_switch_detism(DetismA, DetismB, Detism) :-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_switch_canfail(CanFailA, CanFailB, CanFail),
- det_switch_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln).
-
-%-----------------------------------------------------------------------------%
-%
-% The predicates in this section do abstract interpretation to count
-% the number of solutions and the possible number of failures.
-%
-% If the num_solns is at_most_many_cc, this means that the goal might have
-% many logical solutions if there were no pruning, but that the goal occurs
-% in a single-solution context, so only the first solution will be
-% returned.
-%
-% The reason why we don't throw an exception in det_switch_maxsoln and
-% det_disjunction_maxsoln is given in the documentation of the test case
-% invalid/magicbox.m.
-
-:- pred det_conjunction_maxsoln(soln_count::in, soln_count::in,
- soln_count::out) is det.
-
-det_conjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_one, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_many, at_most_zero).
-
-det_conjunction_maxsoln(at_most_one, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_one, at_most_one, at_most_one).
-det_conjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_conjunction_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_conjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_conjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_conjunction_maxsoln(at_most_many_cc, at_most_many, _) :-
- % If the first conjunct could be cc pruned, the second conj ought to have
- % been cc pruned too.
- error("det_conjunction_maxsoln: many_cc , many").
-
-det_conjunction_maxsoln(at_most_many, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_many, at_most_one, at_most_many).
-det_conjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many).
-det_conjunction_maxsoln(at_most_many, at_most_many, at_most_many).
-
-:- pred det_conjunction_canfail(can_fail::in, can_fail::in, can_fail::out)
- is det.
-
-det_conjunction_canfail(can_fail, can_fail, can_fail).
-det_conjunction_canfail(can_fail, cannot_fail, can_fail).
-det_conjunction_canfail(cannot_fail, can_fail, can_fail).
-det_conjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_disjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_disjunction_maxsoln(at_most_zero, at_most_one, at_most_one).
-det_disjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_zero, at_most_many, at_most_many).
-
-det_disjunction_maxsoln(at_most_one, at_most_zero, at_most_one).
-det_disjunction_maxsoln(at_most_one, at_most_one, at_most_many).
-det_disjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_disjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
-
-det_disjunction_maxsoln(at_most_many, at_most_zero, at_most_many).
-det_disjunction_maxsoln(at_most_many, at_most_one, at_most_many).
-det_disjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many, at_most_many, at_most_many).
-
-det_disjunction_canfail(can_fail, can_fail, can_fail).
-det_disjunction_canfail(can_fail, cannot_fail, cannot_fail).
-det_disjunction_canfail(cannot_fail, can_fail, cannot_fail).
-det_disjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_switch_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_switch_maxsoln(at_most_zero, at_most_one, at_most_one).
-det_switch_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_zero, at_most_many, at_most_many).
-
-det_switch_maxsoln(at_most_one, at_most_zero, at_most_one).
-det_switch_maxsoln(at_most_one, at_most_one, at_most_one).
-det_switch_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_switch_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
-
-det_switch_maxsoln(at_most_many, at_most_zero, at_most_many).
-det_switch_maxsoln(at_most_many, at_most_one, at_most_many).
-det_switch_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_many, at_most_many, at_most_many).
-
-det_switch_canfail(can_fail, can_fail, can_fail).
-det_switch_canfail(can_fail, cannot_fail, can_fail).
-det_switch_canfail(cannot_fail, can_fail, can_fail).
-det_switch_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_negation_det(det, yes(failure)).
-det_negation_det(semidet, yes(semidet)).
-det_negation_det(multidet, no).
-det_negation_det(nondet, no).
-det_negation_det(cc_multidet, no).
-det_negation_det(cc_nondet, no).
-det_negation_det(erroneous, yes(erroneous)).
-det_negation_det(failure, yes(det)).
%-----------------------------------------------------------------------------%
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.52
diff -u -b -r1.52 equiv_type.m
--- compiler/equiv_type.m 28 Oct 2005 02:10:04 -0000 1.52
+++ compiler/equiv_type.m 1 Nov 2005 05:28:21 -0000
@@ -108,6 +108,7 @@
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.22
diff -u -b -r1.22 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 28 Oct 2005 02:10:04 -0000 1.22
+++ compiler/equiv_type_hlds.m 1 Nov 2005 05:30:39 -0000
@@ -746,7 +746,7 @@
%
Goal0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
- TypeCat = type_info_type,
+ TypeCat = type_cat_type_info,
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
Body = eqv_type(_)
@@ -787,7 +787,7 @@
%
Goal0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
- TypeCat = type_ctor_info_type,
+ TypeCat = type_cat_type_ctor_info,
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
Body = eqv_type(_)
Index: compiler/exception_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exception_analysis.m,v
retrieving revision 1.15
diff -u -b -r1.15 exception_analysis.m
--- compiler/exception_analysis.m 28 Oct 2005 02:10:05 -0000 1.15
+++ compiler/exception_analysis.m 1 Nov 2005 06:02:42 -0000
@@ -670,23 +670,25 @@
:- func check_type_2(module_info, mer_type, type_category) = type_status.
-check_type_2(_, _, int_type) = type_will_not_throw.
-check_type_2(_, _, char_type) = type_will_not_throw.
-check_type_2(_, _, str_type) = type_will_not_throw.
-check_type_2(_, _, float_type) = type_will_not_throw.
-check_type_2(_, _, higher_order_type) = type_will_not_throw.
-check_type_2(_, _, type_info_type) = type_will_not_throw.
-check_type_2(_, _, type_ctor_info_type) = type_will_not_throw.
-check_type_2(_, _, typeclass_info_type) = type_will_not_throw.
-check_type_2(_, _, base_typeclass_info_type) = type_will_not_throw.
-check_type_2(_, _, void_type) = type_will_not_throw.
-check_type_2(_, _, dummy_type) = type_will_not_throw.
+check_type_2(_, _, type_cat_int) = type_will_not_throw.
+check_type_2(_, _, type_cat_char) = type_will_not_throw.
+check_type_2(_, _, type_cat_string) = type_will_not_throw.
+check_type_2(_, _, type_cat_float) = type_will_not_throw.
+check_type_2(_, _, type_cat_higher_order) = type_will_not_throw.
+check_type_2(_, _, type_cat_type_info) = type_will_not_throw.
+check_type_2(_, _, type_cat_type_ctor_info) = type_will_not_throw.
+check_type_2(_, _, type_cat_typeclass_info) = type_will_not_throw.
+check_type_2(_, _, type_cat_base_typeclass_info) = type_will_not_throw.
+check_type_2(_, _, type_cat_void) = type_will_not_throw.
+check_type_2(_, _, type_cat_dummy) = type_will_not_throw.
-check_type_2(_, _, variable_type) = type_conditional.
+check_type_2(_, _, type_cat_variable) = type_conditional.
-check_type_2(ModuleInfo, Type, tuple_type) = check_user_type(ModuleInfo, Type).
-check_type_2(ModuleInfo, Type, enum_type) = check_user_type(ModuleInfo, Type).
-check_type_2(ModuleInfo, Type, user_ctor_type) =
+check_type_2(ModuleInfo, Type, type_cat_tuple) =
+ check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, type_cat_enum) =
+ check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, type_cat_user_ctor) =
check_user_type(ModuleInfo, Type).
:- func check_user_type(module_info, mer_type) = type_status.
@@ -697,11 +699,9 @@
type_has_user_defined_equality_pred(ModuleInfo, Type,
_UnifyCompare)
->
- % XXX We can do better than this by examining
- % what these preds actually do. Something
- % similar needs to be sorted out for termination
- % analysis as well, so we'll wait until that is
- % done.
+ % XXX We can do better than this by examining what these preds
+ % actually do. Something similar needs to be sorted out for
+ % termination analysis as well, so we'll wait until that is done.
Status = type_may_throw
;
Status = check_types(ModuleInfo, Args)
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.77
diff -u -b -r1.77 follow_vars.m
--- compiler/follow_vars.m 28 Oct 2005 02:10:05 -0000 1.77
+++ compiler/follow_vars.m 1 Nov 2005 04:01:21 -0000
@@ -34,6 +34,7 @@
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
+:- import_module parse_tree.prog_data.
:- pred find_final_follow_vars(proc_info::in, abs_follow_vars_map::out,
int::out) is det.
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.27
diff -u -b -r1.27 goal_path.m
--- compiler/goal_path.m 28 Oct 2005 02:10:06 -0000 1.27
+++ compiler/goal_path.m 1 Nov 2005 04:05:22 -0000
@@ -16,8 +16,9 @@
:- interface.
:- import_module hlds.hlds_goal.
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
+:- import_module hlds.hlds_module.
+:- import_module parse_tree.prog_data.
:- import_module bool.
Index: compiler/goal_store.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_store.m,v
retrieving revision 1.7
diff -u -b -r1.7 goal_store.m
--- compiler/goal_store.m 28 Oct 2005 02:10:06 -0000 1.7
+++ compiler/goal_store.m 1 Nov 2005 04:04:46 -0000
@@ -21,8 +21,8 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
:- import_module hlds.instmap.
+:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module set.
@@ -30,18 +30,19 @@
%-----------------------------------------------------------------------------%
-:- type goal == pair(hlds_goal, instmap).
+:- type stored_goal == pair(hlds_goal, instmap).
:- type goal_store(T).
:- pred goal_store__init(goal_store(T)::out) is det.
:- func goal_store__init = goal_store(T).
-:- pred goal_store__det_insert(T::in, goal::in,
+:- pred goal_store__det_insert(T::in, stored_goal::in,
goal_store(T)::in, goal_store(T)::out) is det.
-:- pred goal_store__lookup(goal_store(T)::in, T::in, goal::out) is det.
+:- pred goal_store__lookup(goal_store(T)::in, T::in, stored_goal::out) is det.
-:- pred goal_store__member(goal_store(T)::in, T::out, goal::out) is nondet.
+:- pred goal_store__member(goal_store(T)::in, T::out, stored_goal::out)
+ is nondet.
:- pred goal_store__all_ancestors(goal_store(T)::in, T::in, vartypes::in,
module_info::in, bool::in, set(T)::out) is det.
@@ -58,7 +59,7 @@
:- import_module map.
:- import_module require.
-:- type goal_store(T) == map__map(T, goal).
+:- type goal_store(T) == map__map(T, stored_goal).
%-----------------------------------------------------------------------------%
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.118
diff -u -b -r1.118 goal_util.m
--- compiler/goal_util.m 28 Oct 2005 02:10:06 -0000 1.118
+++ compiler/goal_util.m 1 Nov 2005 13:55:12 -0000
@@ -312,10 +312,8 @@
:- implementation.
-:- import_module check_hlds.det_analysis.
:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
-:- import_module check_hlds.purity.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_form.
:- import_module hlds.hlds_data.
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.142
diff -u -b -r1.142 higher_order.m
--- compiler/higher_order.m 28 Oct 2005 02:10:07 -0000 1.142
+++ compiler/higher_order.m 1 Nov 2005 05:36:22 -0000
@@ -63,6 +63,7 @@
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.inlining.
@@ -2215,63 +2216,63 @@
NeedIntCast) :-
TypeCategory = classify_type(ModuleInfo, Type),
(
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
EqvType = Type,
NeedIntCast = no
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
unexpected(this_file,
"dummy type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
unexpected(this_file,
"void type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
unexpected(this_file, "higher_order type in " ++
"find_builtin_type_with_equivalent_compare")
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
unexpected(this_file,
"tuple type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
construct_type(unqualified("int") - 0, [], EqvType),
NeedIntCast = yes
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
unexpected(this_file,
"var type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
unexpected(this_file,
"user type in find_builtin_type_with_equivalent_compare")
;
- TypeCategory = type_info_type,
+ TypeCategory = type_cat_type_info,
unexpected(this_file, "type_info type in " ++
"find_builtin_type_with_equivalent_compare")
;
- TypeCategory = type_ctor_info_type,
+ TypeCategory = type_cat_type_ctor_info,
unexpected(this_file, "type_ctor_info type in " ++
"find_builtin_type_with_equivalent_compare")
;
- TypeCategory = typeclass_info_type,
+ TypeCategory = type_cat_typeclass_info,
unexpected(this_file, "typeclass_info type in " ++
"find_builtin_type_with_equivalent_compare")
;
- TypeCategory = base_typeclass_info_type,
+ TypeCategory = type_cat_base_typeclass_info,
unexpected(this_file, "base_typeclass_info type in " ++
"find_builtin_type_with_equivalent_compare")
).
@@ -2728,14 +2729,14 @@
tvarset_merge_renaming(CallerTypeVarSet, TypeVarSet0, TypeVarSet,
TypeRenaming),
apply_variable_renaming_to_tvar_kind_map(TypeRenaming, KindMap0, KindMap),
- apply_variable_renaming_to_type_map(TypeRenaming, VarTypes0, VarTypes1),
- apply_variable_renaming_to_type_list(TypeRenaming, OriginalArgTypes0,
- OriginalArgTypes1),
+ apply_variable_renaming_to_vartypes(TypeRenaming, VarTypes0, VarTypes1),
+ apply_variable_renaming_to_type_list(TypeRenaming,
+ OriginalArgTypes0, OriginalArgTypes1),
% The real set of existentially quantified variables may be
% smaller, but this is OK.
- apply_variable_renaming_to_tvar_list(TypeRenaming, ExistQVars0,
- ExistQVars1),
+ apply_variable_renaming_to_tvar_list(TypeRenaming,
+ ExistQVars0, ExistQVars1),
inlining.get_type_substitution(OriginalArgTypes1, CallerArgTypes0,
CallerHeadParams, ExistQVars1, TypeSubn),
@@ -2746,9 +2747,9 @@
ExistQType = variable(ExistQVar, _)
), ExistQTypes),
- apply_rec_subst_to_type_map(TypeSubn, VarTypes1, VarTypes2),
- apply_rec_subst_to_type_list(TypeSubn, OriginalArgTypes1,
- OriginalArgTypes),
+ apply_rec_subst_to_vartypes(TypeSubn, VarTypes1, VarTypes2),
+ apply_rec_subst_to_type_list(TypeSubn,
+ OriginalArgTypes1, OriginalArgTypes),
proc_info_set_vartypes(VarTypes2, !NewProcInfo),
% XXX kind inference: we assume vars have kind `star'.
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.99
diff -u -b -r1.99 hlds_data.m
--- compiler/hlds_data.m 28 Oct 2005 02:10:08 -0000 1.99
+++ compiler/hlds_data.m 1 Nov 2005 09:56:18 -0000
@@ -24,12 +24,14 @@
:- import_module list.
:- import_module map.
:- import_module multi_map.
+:- import_module set.
:- import_module std_util.
:- implementation.
:- import_module check_hlds.type_util.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module int.
:- import_module svmulti_map.
@@ -738,45 +740,6 @@
%-----------------------------------------------------------------------------%
:- interface.
-
-% Types and procedures for decomposing and analysing determinism.
-% See also the `code_model' type in code_model.m.
-% The `determinism' type itself is defined in prog_data.m.
-
-:- type can_fail
- ---> can_fail
- ; cannot_fail.
-
-:- type soln_count
- ---> at_most_zero
- ; at_most_one
- ; at_most_many_cc
- % "_cc" means "committed-choice": there is more than one logical
- % solution, but the pred or goal is being used in a context where
- % we are only looking for the first solution.
- ; at_most_many.
-
-:- pred determinism_components(determinism, can_fail, soln_count).
-:- mode determinism_components(in, out, out) is det.
-:- mode determinism_components(out, in, in) is det.
-
-:- implementation.
-
-determinism_components(det, cannot_fail, at_most_one).
-determinism_components(semidet, can_fail, at_most_one).
-determinism_components(multidet, cannot_fail, at_most_many).
-determinism_components(nondet, can_fail, at_most_many).
-determinism_components(cc_multidet, cannot_fail, at_most_many_cc).
-determinism_components(cc_nondet, can_fail, at_most_many_cc).
-determinism_components(erroneous, cannot_fail, at_most_zero).
-determinism_components(failure, can_fail, at_most_zero).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- interface.
-
-:- import_module set.
:- type class_table == map(class_id, hlds_class_defn).
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.142
diff -u -b -r1.142 hlds_goal.m
--- compiler/hlds_goal.m 28 Oct 2005 02:10:08 -0000 1.142
+++ compiler/hlds_goal.m 1 Nov 2005 09:56:36 -0000
@@ -16,7 +16,6 @@
:- interface.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_pred.
:- import_module hlds.instmap.
@@ -1388,12 +1387,12 @@
:- implementation.
-:- import_module check_hlds.det_analysis.
+% :- import_module check_hlds.det_analysis.
:- import_module check_hlds.mode_util.
-:- import_module check_hlds.purity.
:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.122
diff -u -b -r1.122 hlds_module.m
--- compiler/hlds_module.m 28 Oct 2005 02:10:08 -0000 1.122
+++ compiler/hlds_module.m 1 Nov 2005 14:02:27 -0000
@@ -44,11 +44,11 @@
:- implementation.
-:- import_module check_hlds.typecheck.
:- import_module hlds.hlds_out.
:- import_module transform_hlds.mmc_analysis.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module bool.
@@ -1451,6 +1451,22 @@
:- pred predicate_name(module_info::in, pred_id::in, string::out) is det.
:- pred predicate_arity(module_info::in, pred_id::in, arity::out) is det.
+ % Find a predicate which matches the given name and argument types.
+ % Abort if there is no matching pred.
+ % Abort if there are multiple matching preds.
+ %
+:- pred resolve_pred_overloading(module_info::in, pred_markers::in,
+ list(mer_type)::in, tvarset::in, sym_name::in, sym_name::out, pred_id::out)
+ is det.
+
+ % Find a predicate or function from the list of pred_ids
+ % which matches the given name and argument types.
+ % Fail if there is no matching pred.
+ % Abort if there are multiple matching preds.
+ %
+:- pred find_matching_pred_id(module_info::in, list(pred_id)::in, tvarset::in,
+ list(mer_type)::in, pred_id::out, sym_name::out) is semidet.
+
% Get the pred_id and proc_id matching a higher-order term with
% the given argument types, aborting with an error if none is found.
%
@@ -2122,6 +2138,74 @@
%-----------------------------------------------------------------------------%
+resolve_pred_overloading(ModuleInfo, CallerMarkers, ArgTypes, TVarSet,
+ PredName0, PredName, PredId) :-
+ % Note: calls to preds declared in `.opt' files should always be
+ % module qualified, so they should not be considered
+ % when resolving overloading.
+
+ module_info_get_predicate_table(ModuleInfo, PredTable),
+ (
+ predicate_table_search_pred_sym(PredTable,
+ calls_are_fully_qualified(CallerMarkers), PredName0, PredIds0)
+ ->
+ PredIds = PredIds0
+ ;
+ PredIds = []
+ ),
+
+ % Check if there any of the candidate pred_ids have argument/return types
+ % which subsume the actual argument/return types of this function call.
+ (
+ find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ArgTypes,
+ PredId1, PredName1)
+ ->
+ PredId = PredId1,
+ PredName = PredName1
+ ;
+ % If there is no matching predicate for this call, then this predicate
+ % must have a type error which should have been caught by typechecking.
+ unexpected(this_file, "type error in pred call: no matching pred")
+ ).
+
+find_matching_pred_id(ModuleInfo, [PredId | PredIds], TVarSet, ArgTypes,
+ ThePredId, PredName) :-
+ (
+ % Lookup the argument types of the candidate predicate
+ % (or the argument types + return type of the candidate function).
+ %
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_arg_types(PredInfo, PredTVarSet, PredExistQVars0,
+ PredArgTypes0),
+ pred_info_tvar_kinds(PredInfo, PredKindMap),
+
+ arg_type_list_subsumes(TVarSet, ArgTypes, PredTVarSet, PredKindMap,
+ PredExistQVars0, PredArgTypes0)
+ ->
+ % We've found a matching predicate.
+ % Was there was more than one matching predicate/function?
+
+ PName = pred_info_name(PredInfo),
+ Module = pred_info_module(PredInfo),
+ PredName = qualified(Module, PName),
+ (
+ find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ArgTypes,
+ _OtherPredId, _)
+ ->
+ % XXX this should report an error properly, not
+ % via error/1
+ unexpected(this_file, "Type error in predicate call: " ++
+ "unresolvable predicate overloading. " ++
+ "You need to use an explicit module qualifier. " ++
+ "Compile with -V to find out where.")
+ ;
+ ThePredId = PredId
+ )
+ ;
+ find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ArgTypes,
+ ThePredId, PredName)
+ ).
+
get_pred_id(IsFullyQualified, SymName, PredOrFunc, TVarSet,
ArgTypes, ModuleInfo, PredId) :-
module_info_get_predicate_table(ModuleInfo, PredicateTable),
@@ -2130,8 +2214,8 @@
predicate_table_search_pf_sym_arity(PredicateTable, IsFullyQualified,
PredOrFunc, SymName, Arity, PredIds),
% Resolve overloading using the argument types.
- typecheck__find_matching_pred_id(PredIds, ModuleInfo,
- TVarSet, ArgTypes, PredId0, _PredName)
+ find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ArgTypes,
+ PredId0, _PredName)
->
PredId = PredId0
;
@@ -2157,7 +2241,6 @@
"undefined/invalid ", PredOrFuncStr,
"\n`", Name2, "/", ArityString, "'"], Msg),
error(Msg)
-
),
get_proc_id(ModuleInfo, PredId, ProcId).
@@ -2273,5 +2356,11 @@
module_info_preds(ModuleInfo, Preds),
map__lookup(Preds, PredId, PredInfo),
Arity = pred_info_orig_arity(PredInfo).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "hlds_module.m".
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.375
diff -u -b -r1.375 hlds_out.m
--- compiler/hlds_out.m 28 Oct 2005 02:10:09 -0000 1.375
+++ compiler/hlds_out.m 1 Nov 2005 13:30:34 -0000
@@ -34,8 +34,6 @@
:- interface.
-:- import_module hlds.hlds_data.
-% :- import_module hlds__hlds_error_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
@@ -263,10 +261,9 @@
:- implementation.
-:- import_module check_hlds.check_typeclass.
:- import_module check_hlds.mode_util.
-:- import_module check_hlds.purity.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module hlds.instmap.
:- import_module hlds.special_pred.
@@ -277,6 +274,7 @@
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.184
diff -u -b -r1.184 hlds_pred.m
--- compiler/hlds_pred.m 28 Oct 2005 02:10:09 -0000 1.184
+++ compiler/hlds_pred.m 1 Nov 2005 09:48:23 -0000
@@ -49,6 +49,7 @@
:- import_module libs.compiler_util.
:- import_module libs.options.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
% Standard library modules.
@@ -798,8 +799,6 @@
%
:- pred set_clause_list(list(clause)::in, clauses_rep::out) is det.
-:- type vartypes == map(prog_var, mer_type).
-
:- pred clauses_info_varset(clauses_info::in, prog_varset::out) is det.
% This partial map holds the types specified by any explicit
@@ -3449,7 +3448,7 @@
ArgNum, !MaybeIn, !MaybeOut) :-
(
map__lookup(VarTypes, Var, VarType),
- type_util__type_is_io_state(VarType)
+ type_is_io_state(VarType)
->
( mode_is_fully_input(ModuleInfo, Mode) ->
(
@@ -3831,8 +3830,6 @@
:- func eval_method_change_determinism(eval_method, determinism) = determinism.
:- implementation.
-
-:- import_module check_hlds.det_analysis.
valid_determinism_for_eval_method(eval_normal, _) = yes.
valid_determinism_for_eval_method(eval_loop_check, Detism) = Valid :-
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.130
diff -u -b -r1.130 inlining.m
--- compiler/inlining.m 28 Oct 2005 02:10:10 -0000 1.130
+++ compiler/inlining.m 1 Nov 2005 06:03:40 -0000
@@ -144,29 +144,24 @@
:- implementation.
-% Parse tree modules
-:- import_module parse_tree.prog_data.
-
-% HLDS modules
:- import_module check_hlds.det_analysis.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.purity.
-:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
:- import_module hlds.passes_aux.
:- import_module hlds.quantification.
-:- import_module transform_hlds.complexity.
-:- import_module transform_hlds.dead_proc_elim.
-:- import_module transform_hlds.dependency_graph.
-
-% Misc
:- import_module libs.globals.
:- import_module libs.options.
:- import_module libs.trace_params.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
+:- import_module transform_hlds.complexity.
+:- import_module transform_hlds.dead_proc_elim.
+:- import_module transform_hlds.dependency_graph.
-% Standard library modules
:- import_module assoc_list.
:- import_module bool.
:- import_module int.
@@ -705,8 +700,8 @@
tvarset_merge_renaming(TypeVarSet0, CalleeTypeVarSet, TypeVarSet,
TypeRenaming),
- apply_variable_renaming_to_type_map(TypeRenaming, CalleeVarTypes0,
- CalleeVarTypes1),
+ apply_variable_renaming_to_vartypes(TypeRenaming,
+ CalleeVarTypes0, CalleeVarTypes1),
% next, compute the type substitution and then apply it
@@ -726,17 +721,19 @@
inlining__get_type_substitution(HeadTypes, ArgTypes, HeadTypeParams,
CalleeExistQVars, TypeSubn),
- % handle the common case of non-existentially typed preds specially,
+ % Handle the common case of non-existentially typed preds specially,
% since we can do things more efficiently in that case
- ( CalleeExistQVars = [] ->
- % update types in callee only
- apply_rec_subst_to_type_map(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
+ (
+ CalleeExistQVars = [],
+ % Update types in callee only.
+ apply_rec_subst_to_vartypes(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
VarTypes1 = VarTypes0
;
- % update types in callee
- apply_rec_subst_to_type_map(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
- % update types in caller
- apply_rec_subst_to_type_map(TypeSubn, VarTypes0, VarTypes1)
+ CalleeExistQVars = [_ | _],
+ % Update types in callee.
+ apply_rec_subst_to_vartypes(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
+ % Update types in caller.
+ apply_rec_subst_to_vartypes(TypeSubn, VarTypes0, VarTypes1)
),
% Now rename apart the variables in the called goal.
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.69
diff -u -b -r1.69 inst_match.m
--- compiler/inst_match.m 28 Oct 2005 02:10:10 -0000 1.69
+++ compiler/inst_match.m 1 Nov 2005 10:29:32 -0000
@@ -54,7 +54,6 @@
%
:- pred inst_expand(module_info::in, mer_inst::in, mer_inst::out) is det.
-
% inst_expand_and_remove_constrained_inst_vars is the same as inst_expand
% except that it also removes constrained_inst_vars from the top level,
% replacing them with the constraining inst.
@@ -167,7 +166,6 @@
:- pred inst_matches_binding_allow_any_any(mer_inst::in, mer_inst::in,
mer_type::in, module_info::in) is semidet.
-
%-----------------------------------------------------------------------------%
% pred_inst_matches(PredInstA, PredInstB, ModuleInfo)
@@ -310,6 +308,7 @@
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module bool.
:- import_module int.
@@ -2017,21 +2016,21 @@
:- func type_may_contain_solver_type_2(type_category) = bool.
-type_may_contain_solver_type_2(int_type) = no.
-type_may_contain_solver_type_2(char_type) = no.
-type_may_contain_solver_type_2(str_type) = no.
-type_may_contain_solver_type_2(float_type) = no.
-type_may_contain_solver_type_2(higher_order_type) = no.
-type_may_contain_solver_type_2(tuple_type) = yes.
-type_may_contain_solver_type_2(enum_type) = no.
-type_may_contain_solver_type_2(dummy_type) = no.
-type_may_contain_solver_type_2(variable_type) = yes.
-type_may_contain_solver_type_2(type_info_type) = no.
-type_may_contain_solver_type_2(type_ctor_info_type) = no.
-type_may_contain_solver_type_2(typeclass_info_type) = no.
-type_may_contain_solver_type_2(base_typeclass_info_type) = no.
-type_may_contain_solver_type_2(void_type) = no.
-type_may_contain_solver_type_2(user_ctor_type) = yes.
+type_may_contain_solver_type_2(type_cat_int) = no.
+type_may_contain_solver_type_2(type_cat_char) = no.
+type_may_contain_solver_type_2(type_cat_string) = no.
+type_may_contain_solver_type_2(type_cat_float) = no.
+type_may_contain_solver_type_2(type_cat_higher_order) = no.
+type_may_contain_solver_type_2(type_cat_tuple) = yes.
+type_may_contain_solver_type_2(type_cat_enum) = no.
+type_may_contain_solver_type_2(type_cat_dummy) = no.
+type_may_contain_solver_type_2(type_cat_variable) = yes.
+type_may_contain_solver_type_2(type_cat_type_info) = no.
+type_may_contain_solver_type_2(type_cat_type_ctor_info) = no.
+type_may_contain_solver_type_2(type_cat_typeclass_info) = no.
+type_may_contain_solver_type_2(type_cat_base_typeclass_info) = no.
+type_may_contain_solver_type_2(type_cat_void) = no.
+type_may_contain_solver_type_2(type_cat_user_ctor) = yes.
%-----------------------------------------------------------------------------%
Index: compiler/instmap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/instmap.m,v
retrieving revision 1.45
diff -u -b -r1.45 instmap.m
--- compiler/instmap.m 28 Oct 2005 02:10:11 -0000 1.45
+++ compiler/instmap.m 1 Nov 2005 04:00:49 -0000
@@ -25,7 +25,6 @@
:- import_module check_hlds.mode_errors.
:- import_module check_hlds.mode_info.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
:- import_module parse_tree.prog_data.
:- import_module assoc_list.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.183
diff -u -b -r1.183 intermod.m
--- compiler/intermod.m 28 Oct 2005 02:10:11 -0000 1.183
+++ compiler/intermod.m 1 Nov 2005 14:00:59 -0000
@@ -98,7 +98,6 @@
:- import_module backend_libs.foreign.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
-:- import_module check_hlds.typecheck.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
@@ -115,6 +114,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.inlining.
@@ -423,7 +423,7 @@
(
mode_is_input(ModuleInfo, ArgMode),
map__lookup(VarTypes, HeadVar, Type),
- classify_type(ModuleInfo, Type) = higher_order_type
+ classify_type(ModuleInfo, Type) = type_cat_higher_order
;
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes)
).
@@ -866,7 +866,7 @@
InstanceMethodDefn0 = name(InstanceMethodName0),
PredOrFunc = predicate,
init_markers(Markers),
- typecheck__resolve_pred_overloading(ModuleInfo, Markers,
+ resolve_pred_overloading(ModuleInfo, Markers,
MethodCallArgTypes, MethodCallTVarSet,
InstanceMethodName0, InstanceMethodName, PredId),
PredIds = [PredId | PredIds0],
@@ -932,9 +932,8 @@
predicate_table_search_func_sym_arity(PredicateTable,
may_be_partially_qualified, InstanceMethodName0,
MethodArity, PredIds),
- typecheck__find_matching_pred_id(PredIds, ModuleInfo,
- MethodCallTVarSet, MethodCallArgTypes,
- PredId, InstanceMethodFuncName)
+ find_matching_pred_id(ModuleInfo, PredIds, MethodCallTVarSet,
+ MethodCallArgTypes, PredId, InstanceMethodFuncName)
->
TypeCtors = [],
MaybePredId = yes(PredId),
@@ -1101,7 +1100,7 @@
pred_info_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
init_markers(Markers0),
add_marker(calls_are_fully_qualified, Markers0, Markers),
- typecheck__resolve_pred_overloading(ModuleInfo, Markers, ArgTypes,
+ resolve_pred_overloading(ModuleInfo, Markers, ArgTypes,
TVarSet, Pred0, Pred, UserEqPredId),
add_proc(UserEqPredId, _, !Info).
Index: compiler/interval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/interval.m,v
retrieving revision 1.10
diff -u -b -r1.10 interval.m
--- compiler/interval.m 28 Oct 2005 02:10:11 -0000 1.10
+++ compiler/interval.m 1 Nov 2005 04:00:54 -0000
@@ -36,7 +36,6 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
:- import_module parse_tree.prog_data.
:- import_module bool.
Index: compiler/lookup_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lookup_switch.m,v
retrieving revision 1.58
diff -u -b -r1.58 lookup_switch.m
--- compiler/lookup_switch.m 28 Oct 2005 02:10:15 -0000 1.58
+++ compiler/lookup_switch.m 1 Nov 2005 10:20:05 -0000
@@ -44,7 +44,6 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
:- import_module ll_backend.code_info.
@@ -80,6 +79,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.instmap.
:- import_module libs.compiler_util.
:- import_module libs.globals.
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.60
diff -u -b -r1.60 magic.m
--- compiler/magic.m 28 Oct 2005 02:10:15 -0000 1.60
+++ compiler/magic.m 1 Nov 2005 05:01:05 -0000
@@ -542,11 +542,11 @@
),
% Remove aditi:states, convert arguments to output.
- { type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes) },
- { type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes1) },
+ { remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes) },
+ { remove_aditi_state(ArgTypes0, ArgModes0, ArgModes1) },
{ list__map(magic_util__mode_to_output_mode(ModuleInfo0),
ArgModes1, ArgModes) },
- { type_util__remove_aditi_state(ArgTypes0, HeadVars0, HeadVars) },
+ { remove_aditi_state(ArgTypes0, HeadVars0, HeadVars) },
{ pred_info_get_indexes(PredInfo0, Indexes0) },
{ list__map(magic_util__adjust_index(ArgTypes0), Indexes0, Indexes) },
{ pred_info_set_indexes(Indexes, PredInfo0, PredInfo1) },
@@ -588,8 +588,8 @@
PredInfo, ProcInfo) },
{ proc_info_argmodes(ProcInfo, ArgModes0) },
{ pred_info_arg_types(PredInfo, ArgTypes0) },
- { type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes) },
- { type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
+ { remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes) },
+ { remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
{ partition_args(ModuleInfo, ArgModes, ArgModes, InputModes, _) },
{ partition_args(ModuleInfo, ArgModes, ArgTypes, InputTypes, _) },
{ construct_higher_order_type(purity_pure, predicate,
@@ -780,9 +780,9 @@
%
% Strip out the aditi__state argument.
%
- { type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes1) },
- { type_util__remove_aditi_state(ArgTypes0, HeadVars0, HeadVars1) },
- { type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes1) },
+ { remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes1) },
+ { remove_aditi_state(ArgTypes0, HeadVars0, HeadVars1) },
+ { remove_aditi_state(ArgTypes0, ArgModes0, ArgModes1) },
%
% Convert all of the original modes to output. The input
@@ -1055,7 +1055,7 @@
CPredInfo, CProcInfo),
proc_info_argmodes(CProcInfo, ArgModes0),
pred_info_arg_types(CPredInfo, ArgTypes),
- type_util__remove_aditi_state(ArgTypes, ArgModes0, ArgModes),
+ remove_aditi_state(ArgTypes, ArgModes0, ArgModes),
partition_args(ModuleInfo0, ArgModes, ArgModes,
InputArgModes, OutputArgModes),
@@ -1065,8 +1065,7 @@
%
proc_info_vartypes(CProcInfo, VarTypes0),
proc_info_headvars(CProcInfo, HeadVars0),
- type_util__remove_aditi_state(ArgTypes,
- HeadVars0, HeadVars),
+ remove_aditi_state(ArgTypes, HeadVars0, HeadVars),
partition_args(ModuleInfo0, ArgModes, HeadVars,
InputArgs, OutputArgs),
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.56
diff -u -b -r1.56 magic_util.m
--- compiler/magic_util.m 28 Oct 2005 02:10:15 -0000 1.56
+++ compiler/magic_util.m 1 Nov 2005 04:37:39 -0000
@@ -296,8 +296,8 @@
PredInfo, ProcInfo),
pred_info_arg_types(PredInfo, ArgTypes),
proc_info_argmodes(ProcInfo, ArgModes0),
- type_util__remove_aditi_state(ArgTypes, ArgModes0, ArgModes),
- type_util__remove_aditi_state(ArgTypes, Args0, Args),
+ remove_aditi_state(ArgTypes, ArgModes0, ArgModes),
+ remove_aditi_state(ArgTypes, Args0, Args),
partition_args(ModuleInfo, ArgModes, Args, InputArgs, OutputArgs),
Call = db_call(no, Goal0, proc(PredId, ProcId), Args,
InputArgs, OutputArgs, no).
@@ -329,8 +329,7 @@
{ proc_info_vartypes(ProcInfo, VarTypes) },
{ set__to_sorted_list(NonLocals0, NonLocals1) },
{ map__apply_to_list(NonLocals1, VarTypes, NonLocalTypes) },
- { type_util__remove_aditi_state(NonLocalTypes,
- NonLocals1, NonLocals2) },
+ { remove_aditi_state(NonLocalTypes, NonLocals1, NonLocals2) },
{ set__sorted_list_to_set(NonLocals2, NonLocals) }.
make_pred_name(PredInfo, ProcId, Prefix0, AddCount, Name) -->
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.19
diff -u -b -r1.19 make_hlds_passes.m
--- compiler/make_hlds_passes.m 28 Oct 2005 02:10:17 -0000 1.19
+++ compiler/make_hlds_passes.m 1 Nov 2005 05:55:04 -0000
@@ -98,7 +98,6 @@
:- implementation.
:- import_module check_hlds.clause_to_proc.
-:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.
:- import_module hlds.make_hlds.add_class.
@@ -951,8 +950,8 @@
ProcInfos = map.values(ProcTable),
(
ArgTypes = [Arg1Type, Arg2Type],
- type_util.type_is_io_state(Arg1Type),
- type_util.type_is_io_state(Arg2Type),
+ type_is_io_state(Arg1Type),
+ type_is_io_state(Arg2Type),
list.member(ProcInfo, ProcInfos),
proc_info_maybe_declared_argmodes(ProcInfo, MaybeHeadModes),
MaybeHeadModes = yes(HeadModes),
@@ -1060,8 +1059,8 @@
ProcInfos = map.values(ProcTable),
(
ArgTypes = [Arg1Type, Arg2Type],
- type_util.type_is_io_state(Arg1Type),
- type_util.type_is_io_state(Arg2Type),
+ type_is_io_state(Arg1Type),
+ type_is_io_state(Arg2Type),
list.member(ProcInfo, ProcInfos),
proc_info_maybe_declared_argmodes(ProcInfo, MaybeHeadModes),
MaybeHeadModes = yes(HeadModes),
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.49
diff -u -b -r1.49 make_tags.m
--- compiler/make_tags.m 28 Oct 2005 02:10:17 -0000 1.49
+++ compiler/make_tags.m 1 Nov 2005 04:52:07 -0000
@@ -85,10 +85,10 @@
:- implementation.
-:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module int.
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.59
diff -u -b -r1.59 ml_call_gen.m
--- compiler/ml_call_gen.m 28 Oct 2005 02:10:19 -0000 1.59
+++ compiler/ml_call_gen.m 1 Nov 2005 05:15:56 -0000
@@ -775,7 +775,7 @@
% This is needed to handle construction/deconstruction unifications
% for no_tag types.
%
- \+ type_util__type_unify(SourceType, DestType, [], map__init, _)
+ \+ type_unify(SourceType, DestType, [], map__init, _)
->
ml_gen_type(!.Info, DestType, MLDS_DestType),
ArgRval = unop(cast(MLDS_DestType), VarRval)
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.100
diff -u -b -r1.100 ml_code_util.m
--- compiler/ml_code_util.m 28 Oct 2005 02:10:19 -0000 1.100
+++ compiler/ml_code_util.m 1 Nov 2005 05:17:21 -0000
@@ -983,7 +983,7 @@
ml_gen_array_elem_type(elem_type_generic) = mlds__generic_type.
ml_string_type =
- mercury_type(string_type, str_type, non_foreign_type(string_type)).
+ mercury_type(string_type, type_cat_string, non_foreign_type(string_type)).
ml_make_boxed_types(Arity) = BoxedTypes :-
varset__init(TypeVarSet0),
@@ -1576,21 +1576,21 @@
:- func ml_must_box_field_type_category(type_category) = bool.
-ml_must_box_field_type_category(int_type) = no.
-ml_must_box_field_type_category(char_type) = yes.
-ml_must_box_field_type_category(str_type) = no.
-ml_must_box_field_type_category(float_type) = yes.
-ml_must_box_field_type_category(higher_order_type) = no.
-ml_must_box_field_type_category(tuple_type) = no.
-ml_must_box_field_type_category(enum_type) = no.
-ml_must_box_field_type_category(dummy_type) = no.
-ml_must_box_field_type_category(variable_type) = no.
-ml_must_box_field_type_category(type_info_type) = no.
-ml_must_box_field_type_category(type_ctor_info_type) = no.
-ml_must_box_field_type_category(typeclass_info_type) = no.
-ml_must_box_field_type_category(base_typeclass_info_type) = no.
-ml_must_box_field_type_category(void_type) = no.
-ml_must_box_field_type_category(user_ctor_type) = no.
+ml_must_box_field_type_category(type_cat_int) = no.
+ml_must_box_field_type_category(type_cat_char) = yes.
+ml_must_box_field_type_category(type_cat_string) = no.
+ml_must_box_field_type_category(type_cat_float) = yes.
+ml_must_box_field_type_category(type_cat_higher_order) = no.
+ml_must_box_field_type_category(type_cat_tuple) = no.
+ml_must_box_field_type_category(type_cat_enum) = no.
+ml_must_box_field_type_category(type_cat_dummy) = no.
+ml_must_box_field_type_category(type_cat_variable) = no.
+ml_must_box_field_type_category(type_cat_type_info) = no.
+ml_must_box_field_type_category(type_cat_type_ctor_info) = no.
+ml_must_box_field_type_category(type_cat_typeclass_info) = no.
+ml_must_box_field_type_category(type_cat_base_typeclass_info) = no.
+ml_must_box_field_type_category(type_cat_void) = no.
+ml_must_box_field_type_category(type_cat_user_ctor) = no.
%-----------------------------------------------------------------------------%
%
@@ -1972,21 +1972,21 @@
:- func ml_type_category_might_contain_pointers(type_category) = bool.
-ml_type_category_might_contain_pointers(int_type) = no.
-ml_type_category_might_contain_pointers(char_type) = no.
-ml_type_category_might_contain_pointers(str_type) = yes.
-ml_type_category_might_contain_pointers(float_type) = no.
-ml_type_category_might_contain_pointers(void_type) = no.
-ml_type_category_might_contain_pointers(type_info_type) = yes.
-ml_type_category_might_contain_pointers(type_ctor_info_type) = no.
-ml_type_category_might_contain_pointers(typeclass_info_type) = yes.
-ml_type_category_might_contain_pointers(base_typeclass_info_type) = no.
-ml_type_category_might_contain_pointers(higher_order_type) = yes.
-ml_type_category_might_contain_pointers(tuple_type) = yes.
-ml_type_category_might_contain_pointers(enum_type) = no.
-ml_type_category_might_contain_pointers(dummy_type) = no.
-ml_type_category_might_contain_pointers(variable_type) = yes.
-ml_type_category_might_contain_pointers(user_ctor_type) = yes.
+ml_type_category_might_contain_pointers(type_cat_int) = no.
+ml_type_category_might_contain_pointers(type_cat_char) = no.
+ml_type_category_might_contain_pointers(type_cat_string) = yes.
+ml_type_category_might_contain_pointers(type_cat_float) = no.
+ml_type_category_might_contain_pointers(type_cat_void) = no.
+ml_type_category_might_contain_pointers(type_cat_type_info) = yes.
+ml_type_category_might_contain_pointers(type_cat_type_ctor_info) = no.
+ml_type_category_might_contain_pointers(type_cat_typeclass_info) = yes.
+ml_type_category_might_contain_pointers(type_cat_base_typeclass_info) = no.
+ml_type_category_might_contain_pointers(type_cat_higher_order) = yes.
+ml_type_category_might_contain_pointers(type_cat_tuple) = yes.
+ml_type_category_might_contain_pointers(type_cat_enum) = no.
+ml_type_category_might_contain_pointers(type_cat_dummy) = no.
+ml_type_category_might_contain_pointers(type_cat_variable) = yes.
+ml_type_category_might_contain_pointers(type_cat_user_ctor) = yes.
% trace_type_info_type(Type, RealType):
%
@@ -2096,7 +2096,7 @@
mercury_private_builtin_module(PredModule),
MLDS_Module = mercury_module_name_to_mlds(PredModule),
Proc = qual(MLDS_Module, module_qual, Pred - ProcId),
- CPointerType = mercury_type(c_pointer_type, user_ctor_type,
+ CPointerType = mercury_type(c_pointer_type, type_cat_user_ctor,
non_foreign_type(c_pointer_type)),
ArgTypes = [mlds__pseudo_type_info_type, CPointerType],
Signature = mlds__func_signature(ArgTypes, []),
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.13
diff -u -b -r1.13 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m 28 Oct 2005 02:10:20 -0000 1.13
+++ compiler/ml_simplify_switch.m 1 Nov 2005 10:20:35 -0000
@@ -36,10 +36,10 @@
:- implementation.
:- import_module backend_libs.builtin_ops.
-:- import_module check_hlds.type_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module ml_backend.ml_switch_gen.
+:- import_module parse_tree.prog_type.
:- import_module bool.
:- import_module int.
@@ -117,9 +117,9 @@
is_integral_type(mlds__native_int_type).
is_integral_type(mlds__native_char_type).
-is_integral_type(mlds__mercury_type(_, int_type, _)).
-is_integral_type(mlds__mercury_type(_, char_type, _)).
-is_integral_type(mlds__mercury_type(_, enum_type, _)).
+is_integral_type(mlds__mercury_type(_, type_cat_int, _)).
+is_integral_type(mlds__mercury_type(_, type_cat_char, _)).
+is_integral_type(mlds__mercury_type(_, type_cat_enum, _)).
:- pred is_dense_switch(list(mlds__switch_case)::in, int::in) is semidet.
Index: compiler/ml_string_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.21
diff -u -b -r1.21 ml_string_switch.m
--- compiler/ml_string_switch.m 28 Oct 2005 02:10:20 -0000 1.21
+++ compiler/ml_string_switch.m 1 Nov 2005 10:22:09 -0000
@@ -23,7 +23,6 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -38,6 +37,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module ml_backend.ml_code_gen.
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.20
diff -u -b -r1.20 ml_switch_gen.m
--- compiler/ml_switch_gen.m 28 Oct 2005 02:10:20 -0000 1.20
+++ compiler/ml_switch_gen.m 1 Nov 2005 10:22:19 -0000
@@ -67,7 +67,6 @@
:- interface.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module libs.globals.
:- import_module ml_backend.ml_code_util.
@@ -103,6 +102,7 @@
:- import_module backend_libs.foreign.
:- import_module backend_libs.switch_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module libs.compiler_util.
:- import_module libs.options.
:- import_module ml_backend.ml_code_gen.
Index: compiler/ml_tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_tag_switch.m,v
retrieving revision 1.14
diff -u -b -r1.14 ml_tag_switch.m
--- compiler/ml_tag_switch.m 28 Oct 2005 02:10:20 -0000 1.14
+++ compiler/ml_tag_switch.m 1 Nov 2005 10:22:35 -0000
@@ -19,7 +19,6 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -36,6 +35,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module libs.compiler_util.
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.92
diff -u -b -r1.92 ml_unify_gen.m
--- compiler/ml_unify_gen.m 28 Oct 2005 02:10:21 -0000 1.92
+++ compiler/ml_unify_gen.m 1 Nov 2005 05:58:24 -0000
@@ -817,10 +817,10 @@
% since these need to be handled specially;
% their Mercury type definitions are lies.
MLDS_Type = mercury_type(_, TypeCategory, _),
- ( TypeCategory = type_info_type
- ; TypeCategory = type_ctor_info_type
- ; TypeCategory = typeclass_info_type
- ; TypeCategory = base_typeclass_info_type
+ ( TypeCategory = type_cat_type_info
+ ; TypeCategory = type_cat_type_ctor_info
+ ; TypeCategory = type_cat_typeclass_info
+ ; TypeCategory = type_cat_base_typeclass_info
)
->
ConstType = mlds__array_type(mlds__generic_type)
@@ -835,7 +835,7 @@
(
MLDS_Type = mlds__class_type(QualTypeName, TypeArity, _)
;
- MLDS_Type = mercury_type(MercuryType, user_ctor_type, _),
+ MLDS_Type = mercury_type(MercuryType, type_cat_user_ctor, _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity)
)
@@ -856,7 +856,7 @@
% mapped to `mlds__ptr_type(mlds__class_type(...))', but when
% declarating static constants we want just the class type,
% not the pointer type.
- MLDS_Type = mercury_type(MercuryType, user_ctor_type, _),
+ MLDS_Type = mercury_type(MercuryType, type_cat_user_ctor, _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes)
->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
@@ -864,7 +864,7 @@
;
% For tuples, a similar issue arises; we want tuple constants
% to have array type, not the pointer type MR_Tuple.
- MLDS_Type = mercury_type(_, tuple_type, _)
+ MLDS_Type = mercury_type(_, type_cat_tuple, _)
->
ConstType = mlds__array_type(mlds__generic_type)
;
@@ -872,7 +872,7 @@
% the pointer type MR_ClosurePtr. Note that we use a low-level
% data representation for closures, even when --high-level-data
% is enabled.
- MLDS_Type = mercury_type(_, higher_order_type, _)
+ MLDS_Type = mercury_type(_, type_cat_higher_order, _)
->
ConstType = mlds__array_type(mlds__generic_type)
;
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.127
diff -u -b -r1.127 mlds.m
--- compiler/mlds.m 28 Oct 2005 02:10:21 -0000 1.127
+++ compiler/mlds.m 1 Nov 2005 05:19:05 -0000
@@ -333,13 +333,13 @@
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.foreign.
:- import_module backend_libs.rtti.
-:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_foreign.
:- import_module bool.
@@ -1680,6 +1680,7 @@
:- implementation.
:- import_module backend_libs.foreign.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module libs.compiler_util.
:- import_module libs.globals.
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.178
diff -u -b -r1.178 mlds_to_c.m
--- compiler/mlds_to_c.m 28 Oct 2005 02:10:21 -0000 1.178
+++ compiler/mlds_to_c.m 1 Nov 2005 05:20:56 -0000
@@ -1165,7 +1165,7 @@
Kind \= mlds__enum,
ClassType = Type
;
- Type = mercury_type(MercuryType, user_ctor_type, _),
+ Type = mercury_type(MercuryType, type_cat_user_ctor, _),
type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
ClassType = mlds__class_type(ClassName, ClassArity, mlds__class)
@@ -1846,7 +1846,7 @@
HighLevelData = yes,
mlds_output_mercury_user_type_name(
qualified(unqualified("array"), "array") - 1,
- user_ctor_type, !IO)
+ type_cat_user_ctor, !IO)
;
HighLevelData = no,
io__write_string("MR_ArrayPtr", !IO)
@@ -1938,48 +1938,48 @@
mlds_output_mercury_type_prefix(Type, TypeCategory, !IO) :-
(
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
io__write_string("MR_Char", !IO)
;
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
io__write_string("MR_Integer", !IO)
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
io__write_string("MR_String", !IO)
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
io__write_string("MR_Float", !IO)
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
io__write_string("MR_Word", !IO)
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
io__write_string("MR_Box", !IO)
;
- TypeCategory = type_info_type,
+ TypeCategory = type_cat_type_info,
% runtime/mercury_hlc_types requires typeclass_infos
% to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, user_ctor_type, !IO)
+ mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = type_ctor_info_type,
+ TypeCategory = type_cat_type_ctor_info,
% runtime/mercury_hlc_types requires typeclass_infos
% to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, user_ctor_type, !IO)
+ mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = typeclass_info_type,
+ TypeCategory = type_cat_typeclass_info,
% runtime/mercury_hlc_types requires typeclass_infos
% to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, user_ctor_type, !IO)
+ mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = base_typeclass_info_type,
+ TypeCategory = type_cat_base_typeclass_info,
% runtime/mercury_hlc_types requires typeclass_infos
% to be treated as user defined types.
- mlds_output_mercury_user_type_prefix(Type, user_ctor_type, !IO)
+ mlds_output_mercury_user_type_prefix(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
io__write_string("MR_Tuple", !IO)
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
globals__io_lookup_bool_option(highlevel_data, HighLevelData, !IO),
(
HighLevelData = yes,
@@ -1989,13 +1989,13 @@
io__write_string("MR_Word", !IO)
)
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
mlds_output_mercury_user_type_prefix(Type, TypeCategory, !IO)
).
@@ -2022,7 +2022,7 @@
mlds_output_mercury_user_type_name(TypeCtor, TypeCategory, !IO) :-
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
- ( TypeCategory = enum_type ->
+ ( TypeCategory = type_cat_enum ->
MLDS_Type = mlds__class_type(ClassName, ClassArity, mlds__enum)
;
MLDS_Type = mlds__ptr_type(
@@ -3266,7 +3266,7 @@
mlds_output_boxed_rval(Type, Exprn, !IO) :-
(
( Type = mlds__generic_type
- ; Type = mlds__mercury_type(_, variable_type, _)
+ ; Type = mlds__mercury_type(_, type_cat_variable, _)
)
->
% It already has type MR_Box, so no cast is needed.
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.110
diff -u -b -r1.110 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 28 Oct 2005 02:10:21 -0000 1.110
+++ compiler/mlds_to_gcc.m 1 Nov 2005 07:24:09 -0000
@@ -163,7 +163,6 @@
:- import_module backend_libs.name_mangle.
:- import_module backend_libs.pseudo_type_info.
:- import_module backend_libs.rtti. % for rtti.addr_to_string.
-:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_pred. % for proc_id_to_int and invalid_pred_id
:- import_module hlds.passes_aux.
@@ -180,6 +179,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -1864,28 +1864,28 @@
build_mercury_type(Type, TypeCategory, GCC_Type) -->
(
- { TypeCategory = char_type },
+ { TypeCategory = type_cat_char },
{ GCC_Type = 'MR_Char' }
;
- { TypeCategory = int_type },
+ { TypeCategory = type_cat_int },
{ GCC_Type = 'MR_Integer' }
;
- { TypeCategory = str_type },
+ { TypeCategory = type_cat_string },
{ GCC_Type = 'MR_String' }
;
- { TypeCategory = float_type },
+ { TypeCategory = type_cat_float },
{ GCC_Type = 'MR_Float' }
;
- { TypeCategory = void_type },
+ { TypeCategory = type_cat_void },
{ GCC_Type = 'MR_Word' }
;
- { TypeCategory = type_info_type },
- build_mercury_type(Type, user_ctor_type, GCC_Type)
+ { TypeCategory = type_cat_type_info },
+ build_mercury_type(Type, type_cat_user_ctor, GCC_Type)
;
- { TypeCategory = type_ctor_info_type },
- build_mercury_type(Type, user_ctor_type, GCC_Type)
+ { TypeCategory = type_cat_type_ctor_info },
+ build_mercury_type(Type, type_cat_user_ctor, GCC_Type)
;
- { TypeCategory = typeclass_info_type },
+ { TypeCategory = type_cat_typeclass_info },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file,
@@ -1894,7 +1894,7 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = base_typeclass_info_type },
+ { TypeCategory = type_cat_base_typeclass_info },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file,
@@ -1903,16 +1903,16 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = variable_type },
+ { TypeCategory = type_cat_variable },
{ GCC_Type = 'MR_Box' }
;
- { TypeCategory = tuple_type },
+ { TypeCategory = type_cat_tuple },
% tuples are always (pointers to)
% arrays of polymorphic terms
gcc__build_pointer_type('MR_Box', MR_Tuple),
{ GCC_Type = MR_Tuple }
;
- { TypeCategory = higher_order_type },
+ { TypeCategory = type_cat_higher_order },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (pred_type)") }
@@ -1921,7 +1921,9 @@
{ GCC_Type = 'MR_Word' }
)
;
- { TypeCategory = enum_type ; TypeCategory = dummy_type },
+ { TypeCategory = type_cat_enum
+ ; TypeCategory = type_cat_dummy
+ },
% Note that the MLDS -> C back-end uses 'MR_Word' here,
% unless --high-level-data is enabled. But 'MR_Integer'
% seems better, I think. It probably doesn't make any real
@@ -1929,7 +1931,7 @@
% XXX for --high-level-data, we should use a real enum type
{ GCC_Type = 'MR_Integer' }
;
- { TypeCategory = user_ctor_type },
+ { TypeCategory = type_cat_user_ctor },
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
( { HighLevelData = yes } ->
{ sorry(this_file, "--high-level-data (user_type)") }
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.154
diff -u -b -r1.154 mlds_to_il.m
--- compiler/mlds_to_il.m 28 Oct 2005 02:10:21 -0000 1.154
+++ compiler/mlds_to_il.m 1 Nov 2005 05:23:26 -0000
@@ -1157,7 +1157,7 @@
UnivSymName = qualified(unqualified("std_util"), "univ"),
UnivMercuryType = defined(UnivSymName, [], star),
UnivMLDSType = mercury_type(UnivMercuryType,
- user_ctor_type, non_foreign_type(UnivMercuryType)),
+ type_cat_user_ctor, non_foreign_type(UnivMercuryType)),
UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType),
RenameNode = (func(N) = list__map(RenameRets, N)),
@@ -2000,7 +2000,7 @@
Type = mlds__class_type(_, _, mlds__class)
;
DataRep ^ highlevel_data = yes,
- Type = mlds__mercury_type(MercuryType, user_ctor_type, _),
+ Type = mlds__mercury_type(MercuryType, type_cat_user_ctor, _),
\+ type_needs_lowlevel_rep(il, MercuryType)
)
->
@@ -2518,7 +2518,7 @@
% XXX Consider whether this is the right way to handle
% type_infos, type_ctor_infos, typeclass_infos and
% base_typeclass_infos.
- ( TypeCategory = user_ctor_type
+ ( TypeCategory = type_cat_user_ctor
; is_introduced_type_info_type_category(TypeCategory) = yes
)
->
@@ -3001,7 +3001,7 @@
mlds_type_to_ilds_type(_, mlds__rtti_type(_RttiName)) = il_object_array_type.
mlds_type_to_ilds_type(DataRep, mlds__mercury_array_type(ElementType)) =
- ( ElementType = mlds__mercury_type(_, variable_type, _) ->
+ ( ElementType = mlds__mercury_type(_, type_cat_variable, _) ->
il_generic_array_type
;
ilds__type([], '[]'(mlds_type_to_ilds_type(DataRep,
@@ -3091,26 +3091,27 @@
:- func mlds_mercury_type_to_ilds_type(il_data_rep, mer_type,
type_category) = ilds__type.
-mlds_mercury_type_to_ilds_type(_, _, int_type) = ilds__type([], int32).
-mlds_mercury_type_to_ilds_type(_, _, char_type) = ilds__type([], char).
-mlds_mercury_type_to_ilds_type(_, _, float_type) = ilds__type([], float64).
-mlds_mercury_type_to_ilds_type(_, _, str_type) = il_string_type.
-mlds_mercury_type_to_ilds_type(_, _, void_type) = ilds__type([], int32).
-mlds_mercury_type_to_ilds_type(_, _, higher_order_type) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, tuple_type) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, enum_type) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, dummy_type) = il_object_array_type.
-mlds_mercury_type_to_ilds_type(_, _, variable_type) = il_generic_type.
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_info_type) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_ctor_info_type) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, typeclass_info_type) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
+mlds_mercury_type_to_ilds_type(_, _, type_cat_int) = ilds__type([], int32).
+mlds_mercury_type_to_ilds_type(_, _, type_cat_char) = ilds__type([], char).
+mlds_mercury_type_to_ilds_type(_, _, type_cat_float) = ilds__type([], float64).
+mlds_mercury_type_to_ilds_type(_, _, type_cat_string) = il_string_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_void) = ilds__type([], int32).
+mlds_mercury_type_to_ilds_type(_, _, type_cat_higher_order) =
+ il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_tuple) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_enum) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_dummy) = il_object_array_type.
+mlds_mercury_type_to_ilds_type(_, _, type_cat_variable) = il_generic_type.
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_type_info) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_type_ctor_info) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_typeclass_info) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
mlds_mercury_type_to_ilds_type(DataRep, MercuryType,
- base_typeclass_info_type) =
- mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type).
-mlds_mercury_type_to_ilds_type(DataRep, MercuryType, user_ctor_type) =
+ type_cat_base_typeclass_info) =
+ mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor).
+mlds_mercury_type_to_ilds_type(DataRep, MercuryType, type_cat_user_ctor) =
(
DataRep ^ highlevel_data = yes,
\+ type_needs_lowlevel_rep(il, MercuryType)
@@ -3572,18 +3573,19 @@
rval_const_to_type(code_addr_const(_))
= mlds__func_type(mlds__func_params([], [])).
rval_const_to_type(int_const(_))
- = mercury_type(IntType, int_type, non_foreign_type(IntType)) :-
+ = mercury_type(IntType, type_cat_int, non_foreign_type(IntType)) :-
IntType = builtin(int).
rval_const_to_type(float_const(_))
- = mercury_type(FloatType, float_type, non_foreign_type(FloatType)) :-
+ = mercury_type(FloatType, type_cat_float,
+ non_foreign_type(FloatType)) :-
FloatType = builtin(float).
rval_const_to_type(false) = mlds__native_bool_type.
rval_const_to_type(true) = mlds__native_bool_type.
rval_const_to_type(string_const(_))
- = mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
+ = mercury_type(StrType, type_cat_string, non_foreign_type(StrType)) :-
StrType = builtin(string).
rval_const_to_type(multi_string_const(_, _))
- = mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
+ = mercury_type(StrType, type_cat_string, non_foreign_type(StrType)) :-
StrType = builtin(string).
rval_const_to_type(null(MldsType)) = MldsType.
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.72
diff -u -b -r1.72 mlds_to_java.m
--- compiler/mlds_to_java.m 28 Oct 2005 02:10:22 -0000 1.72
+++ compiler/mlds_to_java.m 1 Nov 2005 05:27:22 -0000
@@ -187,7 +187,7 @@
type_is_enum(Type) :-
Type = mercury_type(_, Builtin, _),
- Builtin = enum_type.
+ Builtin = type_cat_enum.
% Succeeds iff this type is something that the Java backend will represent
% as an object i.e. something created using the new operator.
@@ -200,21 +200,21 @@
:- func type_category_is_object(type_category) = bool.
-type_category_is_object(int_type) = no.
-type_category_is_object(char_type) = no.
-type_category_is_object(str_type) = no.
-type_category_is_object(float_type) = no.
-type_category_is_object(higher_order_type) = no.
-type_category_is_object(tuple_type) = no.
-type_category_is_object(enum_type) = yes.
-type_category_is_object(dummy_type) = yes.
-type_category_is_object(variable_type) = yes.
-type_category_is_object(type_info_type) = yes.
-type_category_is_object(type_ctor_info_type) = yes.
-type_category_is_object(typeclass_info_type) = yes.
-type_category_is_object(base_typeclass_info_type) = yes.
-type_category_is_object(void_type) = no.
-type_category_is_object(user_ctor_type) = yes.
+type_category_is_object(type_cat_int) = no.
+type_category_is_object(type_cat_char) = no.
+type_category_is_object(type_cat_string) = no.
+type_category_is_object(type_cat_float) = no.
+type_category_is_object(type_cat_higher_order) = no.
+type_category_is_object(type_cat_tuple) = no.
+type_category_is_object(type_cat_enum) = yes.
+type_category_is_object(type_cat_dummy) = yes.
+type_category_is_object(type_cat_variable) = yes.
+type_category_is_object(type_cat_type_info) = yes.
+type_category_is_object(type_cat_type_ctor_info) = yes.
+type_category_is_object(type_cat_typeclass_info) = yes.
+type_category_is_object(type_cat_base_typeclass_info) = yes.
+type_category_is_object(type_cat_void) = no.
+type_category_is_object(type_cat_user_ctor) = yes.
% Given an lval, return its type.
%
@@ -1347,22 +1347,24 @@
%
:- func get_java_type_initializer(mlds_type) = string.
-get_java_type_initializer(mercury_type(_, int_type, _)) = "0".
-get_java_type_initializer(mercury_type(_, char_type, _)) = "0".
-get_java_type_initializer(mercury_type(_, float_type, _)) = "0".
-get_java_type_initializer(mercury_type(_, str_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, void_type, _)) = "0".
-get_java_type_initializer(mercury_type(_, type_info_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, type_ctor_info_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, typeclass_info_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, base_typeclass_info_type, _))
+get_java_type_initializer(mercury_type(_, type_cat_int, _)) = "0".
+get_java_type_initializer(mercury_type(_, type_cat_char, _)) = "0".
+get_java_type_initializer(mercury_type(_, type_cat_float, _)) = "0".
+get_java_type_initializer(mercury_type(_, type_cat_string, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_void, _)) = "0".
+get_java_type_initializer(mercury_type(_, type_cat_type_info, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_type_ctor_info, _))
= "null".
-get_java_type_initializer(mercury_type(_, higher_order_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, tuple_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, enum_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, dummy_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, variable_type, _)) = "null".
-get_java_type_initializer(mercury_type(_, user_ctor_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_typeclass_info, _))
+ = "null".
+get_java_type_initializer(mercury_type(_, type_cat_base_typeclass_info, _))
+ = "null".
+get_java_type_initializer(mercury_type(_, type_cat_higher_order, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_tuple, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_enum, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_dummy, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_variable, _)) = "null".
+get_java_type_initializer(mercury_type(_, type_cat_user_ctor, _)) = "null".
get_java_type_initializer(mlds__mercury_array_type(_)) = "null".
get_java_type_initializer(mlds__cont_type(_)) = "null".
get_java_type_initializer(mlds__commit_type) = "null".
@@ -1755,7 +1757,7 @@
).
output_type(mercury_array_type(ElementType), !IO) :-
- ( ElementType = mlds__mercury_type(_, variable_type, _) ->
+ ( ElementType = mlds__mercury_type(_, type_cat_variable, _) ->
% We can't use `java.lang.Object []', since we want a generic type
% that is capable of holding any kind of array, including e.g.
% `int []'. Java doesn't have any equivalent of .NET's System.Array
@@ -1828,50 +1830,50 @@
output_mercury_type(Type, TypeCategory, !IO) :-
(
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
io__write_string("char", !IO)
;
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
io__write_string("int", !IO)
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
io__write_string("java.lang.String", !IO)
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
io__write_string("double", !IO)
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
% Shouldn't matter what we put here.
io__write_string("int", !IO)
;
- TypeCategory = type_info_type,
- output_mercury_user_type(Type, user_ctor_type, !IO)
+ TypeCategory = type_cat_type_info,
+ output_mercury_user_type(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = type_ctor_info_type,
- output_mercury_user_type(Type, user_ctor_type, !IO)
+ TypeCategory = type_cat_type_ctor_info,
+ output_mercury_user_type(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = typeclass_info_type,
- output_mercury_user_type(Type, user_ctor_type, !IO)
+ TypeCategory = type_cat_typeclass_info,
+ output_mercury_user_type(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = base_typeclass_info_type,
- output_mercury_user_type(Type, user_ctor_type, !IO)
+ TypeCategory = type_cat_base_typeclass_info,
+ output_mercury_user_type(Type, type_cat_user_ctor, !IO)
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
io__write_string("java.lang.Object", !IO)
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
io__write_string("/* tuple */ java.lang.Object[]", !IO)
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
io__write_string("/* closure */ java.lang.Object[]", !IO)
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
output_mercury_user_type(Type, TypeCategory, !IO)
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
output_mercury_user_type(Type, TypeCategory, !IO)
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
output_mercury_user_type(Type, TypeCategory, !IO)
).
@@ -1881,7 +1883,7 @@
output_mercury_user_type(Type, TypeCategory, !IO) :-
( type_to_ctor_and_args(Type, TypeCtor, _ArgsTypes) ->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
- ( TypeCategory = enum_type ->
+ ( TypeCategory = type_cat_enum ->
MLDS_Type = mlds__class_type(ClassName, ClassArity, mlds__enum)
;
MLDS_Type = mlds__class_type(ClassName, ClassArity, mlds__class)
@@ -1908,24 +1910,25 @@
IsArray = no
).
- % return yes if the corresponding Java type is an array type.
+ % Return yes if the corresponding Java type is an array type.
+ %
:- func type_category_is_array(type_category) = bool.
-type_category_is_array(int_type) = no.
-type_category_is_array(char_type) = no.
-type_category_is_array(str_type) = no.
-type_category_is_array(float_type) = no.
-type_category_is_array(higher_order_type) = yes.
-type_category_is_array(tuple_type) = yes.
-type_category_is_array(enum_type) = no.
-type_category_is_array(dummy_type) = no.
-type_category_is_array(variable_type) = no.
-type_category_is_array(type_info_type) = no.
-type_category_is_array(type_ctor_info_type) = no.
-type_category_is_array(typeclass_info_type) = yes.
-type_category_is_array(base_typeclass_info_type) = yes.
-type_category_is_array(void_type) = no.
-type_category_is_array(user_ctor_type) = no.
+type_category_is_array(type_cat_int) = no.
+type_category_is_array(type_cat_char) = no.
+type_category_is_array(type_cat_string) = no.
+type_category_is_array(type_cat_float) = no.
+type_category_is_array(type_cat_higher_order) = yes.
+type_category_is_array(type_cat_tuple) = yes.
+type_category_is_array(type_cat_enum) = no.
+type_category_is_array(type_cat_dummy) = no.
+type_category_is_array(type_cat_variable) = no.
+type_category_is_array(type_cat_type_info) = no.
+type_category_is_array(type_cat_type_ctor_info) = no.
+type_category_is_array(type_cat_typeclass_info) = yes.
+type_category_is_array(type_cat_base_typeclass_info) = yes.
+type_category_is_array(type_cat_void) = no.
+type_category_is_array(type_cat_user_ctor) = no.
% hand_defined_type(Type, SubstituteName):
%
@@ -1934,11 +1937,12 @@
%
:- pred hand_defined_type(type_category::in, string::out) is semidet.
-hand_defined_type(type_info_type, "mercury.runtime.TypeInfo_Struct").
-hand_defined_type(type_ctor_info_type, "mercury.runtime.TypeCtorInfo_Struct").
-hand_defined_type(base_typeclass_info_type,
+hand_defined_type(type_cat_type_info, "mercury.runtime.TypeInfo_Struct").
+hand_defined_type(type_cat_type_ctor_info,
+ "mercury.runtime.TypeCtorInfo_Struct").
+hand_defined_type(type_cat_base_typeclass_info,
"/* base_typeclass_info */ java.lang.Object[]").
-hand_defined_type(typeclass_info_type,
+hand_defined_type(type_cat_typeclass_info,
"/* typeclass_info */ java.lang.Object[]").
%-----------------------------------------------------------------------------%
@@ -2974,7 +2978,7 @@
output_rval(ModuleInfo, Exprn, ModuleName, !IO),
io__write_string(")", !IO)
;
- ( Type = mlds__mercury_type(_, type_info_type, _)
+ ( Type = mlds__mercury_type(_, type_cat_type_info, _)
; Type = mlds__type_info_type
)
->
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.177
diff -u -b -r1.177 mode_util.m
--- compiler/mode_util.m 28 Oct 2005 02:10:23 -0000 1.177
+++ compiler/mode_util.m 1 Nov 2005 04:44:54 -0000
@@ -197,6 +197,7 @@
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.354
diff -u -b -r1.354 modules.m
--- compiler/modules.m 28 Oct 2005 02:10:25 -0000 1.354
+++ compiler/modules.m 1 Nov 2005 06:08:04 -0000
@@ -785,7 +785,6 @@
:- implementation.
-:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
:- import_module libs.handle_options.
:- import_module libs.options.
Index: compiler/parse_tree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/parse_tree.m,v
retrieving revision 1.12
diff -u -b -r1.12 parse_tree.m
--- compiler/parse_tree.m 12 Oct 2005 23:51:37 -0000 1.12
+++ compiler/parse_tree.m 1 Nov 2005 03:14:36 -0000
@@ -41,6 +41,7 @@
:- include_module prog_mutable.
:- include_module prog_util.
:- include_module prog_type.
+:- include_module prog_type_subst.
:- include_module error_util.
% Transformations that act on the parse tree,
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.43
diff -u -b -r1.43 pd_util.m
--- compiler/pd_util.m 28 Oct 2005 02:10:27 -0000 1.43
+++ compiler/pd_util.m 1 Nov 2005 05:34:54 -0000
@@ -156,7 +156,6 @@
:- import_module check_hlds.mode_info.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.purity.
-:- import_module check_hlds.type_util.
:- import_module check_hlds.unique_modes.
:- import_module hlds.goal_form.
:- import_module hlds.goal_util.
@@ -166,6 +165,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module parse_tree.prog_type.
:- import_module transform_hlds.constraint.
:- import_module transform_hlds.pd_cost.
:- import_module transform_hlds.pd_debug.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.283
diff -u -b -r1.283 polymorphism.m
--- compiler/polymorphism.m 28 Oct 2005 02:10:28 -0000 1.283
+++ compiler/polymorphism.m 1 Nov 2005 05:02:53 -0000
@@ -391,6 +391,7 @@
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -2630,23 +2631,23 @@
:- func get_category_name(type_category) = maybe(string).
-get_category_name(int_type) = yes("int").
-get_category_name(char_type) = yes("int").
-get_category_name(enum_type) = no.
-get_category_name(dummy_type) = no.
-get_category_name(float_type) = yes("float").
-get_category_name(str_type) = yes("string").
-get_category_name(higher_order_type) = yes("pred").
-get_category_name(tuple_type) = yes("tuple").
-get_category_name(variable_type) = _ :-
+get_category_name(type_cat_int) = yes("int").
+get_category_name(type_cat_char) = yes("int").
+get_category_name(type_cat_enum) = no.
+get_category_name(type_cat_dummy) = no.
+get_category_name(type_cat_float) = yes("float").
+get_category_name(type_cat_string) = yes("string").
+get_category_name(type_cat_higher_order) = yes("pred").
+get_category_name(type_cat_tuple) = yes("tuple").
+get_category_name(type_cat_variable) = _ :-
unexpected(this_file, "get_category_name: variable type").
-get_category_name(void_type) = _ :-
+get_category_name(type_cat_void) = _ :-
unexpected(this_file, "get_category_name: void_type").
-get_category_name(user_ctor_type) = no.
-get_category_name(type_info_type) = no.
-get_category_name(type_ctor_info_type) = no.
-get_category_name(typeclass_info_type) = no.
-get_category_name(base_typeclass_info_type) = no.
+get_category_name(type_cat_user_ctor) = no.
+get_category_name(type_cat_type_info) = no.
+get_category_name(type_cat_type_ctor_info) = no.
+get_category_name(type_cat_typeclass_info) = no.
+get_category_name(type_cat_base_typeclass_info) = no.
init_type_info_var(Type, ArgVars, MaybePreferredVar, TypeInfoVar, TypeInfoGoal,
!VarSet, !VarTypes, !RttiVarMaps) :-
Index: compiler/post_term_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_term_analysis.m,v
retrieving revision 1.8
diff -u -b -r1.8 post_term_analysis.m
--- compiler/post_term_analysis.m 28 Oct 2005 14:00:34 -0000 1.8
+++ compiler/post_term_analysis.m 1 Nov 2005 05:36:52 -0000
@@ -35,7 +35,6 @@
:- import_module backend_libs.
:- import_module backend_libs.foreign.
-:- import_module check_hlds.type_util.
:- import_module hlds.goal_form.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
@@ -50,6 +49,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module bool.
:- import_module list.
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.87
diff -u -b -r1.87 post_typecheck.m
--- compiler/post_typecheck.m 28 Oct 2005 02:10:28 -0000 1.87
+++ compiler/post_typecheck.m 1 Nov 2005 14:27:09 -0000
@@ -145,6 +145,7 @@
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -309,7 +310,7 @@
constraint_proof_map::in, constraint_proof_map::out,
constraint_map::in, constraint_map::out) is det.
-bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypesMap, !Proofs,
+bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypes, !Proofs,
!ConstraintMap) :-
% Create a substitution that maps all of the unbound type variables
% to `void'.
@@ -319,7 +320,7 @@
set__fold(MapToVoid, UnboundTypeVarsSet, map__init, VoidSubst),
% Then apply the substitution we just created to the various maps.
- apply_subst_to_type_map(VoidSubst, !VarTypesMap),
+ apply_subst_to_vartypes(VoidSubst, !VarTypes),
apply_subst_to_constraint_proofs(VoidSubst, !Proofs),
apply_subst_to_constraint_map(VoidSubst, !ConstraintMap).
@@ -444,8 +445,8 @@
pred_info_clauses_info(CallerPredInfo, ClausesInfo),
clauses_info_vartypes(ClausesInfo, VarTypes),
map__apply_to_list(Args0, VarTypes, ArgTypes),
- typecheck__resolve_pred_overloading(ModuleInfo, Markers,
- ArgTypes, TVarSet, !PredName, !:PredId)
+ resolve_pred_overloading(ModuleInfo, Markers, ArgTypes, TVarSet,
+ !PredName, !:PredId)
;
!:PredName = get_qualified_pred_name(ModuleInfo, !.PredId)
).
@@ -588,8 +589,8 @@
->
call(AdjustArgTypes, ArgTypes0, ArgTypes),
pred_info_get_markers(CallerPredInfo, Markers),
- typecheck__resolve_pred_overloading(ModuleInfo, Markers, ArgTypes,
- TVarSet, SymName0, SymName, PredId)
+ resolve_pred_overloading(ModuleInfo, Markers, ArgTypes, TVarSet,
+ SymName0, SymName, PredId)
;
unexpected(this_file, "resolve_aditi_builtin_overloading")
)
@@ -1135,8 +1136,8 @@
pred_info_typevarset(!.PredInfo, TVarSet),
map__apply_to_list(ArgVars0, !.VarTypes, ArgTypes0),
list__append(ArgTypes0, [TypeOfX], ArgTypes),
- typecheck__find_matching_pred_id(PredIds, ModuleInfo,
- TVarSet, ArgTypes, PredId, QualifiedFuncName)
+ find_matching_pred_id(ModuleInfo, PredIds, TVarSet, ArgTypes,
+ PredId, QualifiedFuncName)
->
% Convert function calls into predicate calls:
% replace `X = f(A, B, C)' with `f(A, B, C, X)'.
@@ -1517,8 +1518,7 @@
TermTypeCtor = TermTypeCtor0
;
unexpected(this_file,
- "get_constructor_containing_field: " ++
- "type_to_ctor_and_args failed")
+ "get_constructor_containing_field: type_to_ctor_and_args failed")
),
module_info_get_type_table(ModuleInfo, Types),
map__lookup(Types, TermTypeCtor, TermTypeDefn),
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.144
diff -u -b -r1.144 prog_data.m
--- compiler/prog_data.m 28 Oct 2005 02:10:29 -0000 1.144
+++ compiler/prog_data.m 1 Nov 2005 10:08:15 -0000
@@ -253,9 +253,20 @@
; purity_semipure
; purity_impure.
+ % Compare two purities.
+ %
+:- pred less_pure(purity::in, purity::in) is semidet.
+
+ % Sort of a "maximum" for impurity.
+ %
+:- func worst_purity(purity, purity) = purity.
+
+ % Sort of a "minimum" for impurity.
+ %
+:- func best_purity(purity, purity) = purity.
+
% The `determinism' type specifies how many solutions a given procedure
- % may have. Procedures for manipulating this type are defined in
- % det_analysis.m and hlds_data.m.
+ % may have.
%
:- type determinism
---> det
@@ -267,6 +278,54 @@
; erroneous
; failure.
+:- type can_fail
+ ---> can_fail
+ ; cannot_fail.
+
+:- type soln_count
+ ---> at_most_zero
+ ; at_most_one
+ ; at_most_many_cc
+ % "_cc" means "committed-choice": there is more than one logical
+ % solution, but the pred or goal is being used in a context where
+ % we are only looking for the first solution.
+ ; at_most_many.
+
+:- pred determinism_components(determinism, can_fail, soln_count).
+:- mode determinism_components(in, out, out) is det.
+:- mode determinism_components(out, in, in) is det.
+
+ % The following predicates implement the tables for computing the
+ % determinism of compound goals from the determinism of their components.
+
+:- pred det_conjunction_detism(determinism::in, determinism::in,
+ determinism::out) is det.
+
+:- pred det_par_conjunction_detism(determinism::in, determinism::in,
+ determinism::out) is det.
+
+:- pred det_switch_detism(determinism::in, determinism::in, determinism::out)
+ is det.
+
+:- pred det_negation_det(determinism::in, maybe(determinism)::out) is det.
+
+:- pred det_conjunction_maxsoln(soln_count::in, soln_count::in,
+ soln_count::out) is det.
+
+:- pred det_conjunction_canfail(can_fail::in, can_fail::in, can_fail::out)
+ is det.
+
+:- pred det_disjunction_maxsoln(soln_count::in, soln_count::in,
+ soln_count::out) is det.
+
+:- pred det_disjunction_canfail(can_fail::in, can_fail::in, can_fail::out)
+ is det.
+
+:- pred det_switch_maxsoln(soln_count::in, soln_count::in, soln_count::out)
+ is det.
+
+:- pred det_switch_canfail(can_fail::in, can_fail::in, can_fail::out) is det.
+
% The `is_solver_type' type specifies whether a type is a "solver" type,
% for which `any' insts are interpreted as "don't know", or a non-solver
% type for which `any' is the same as `bound(...)'.
@@ -1536,6 +1595,8 @@
% A type expression with an explicit kind annotation.
% (These are not yet used.)
+:- type vartypes == map(prog_var, mer_type).
+
:- type builtin_type
---> int
; float
@@ -1955,6 +2016,7 @@
:- import_module libs.compiler_util.
+:- import_module require.
:- import_module string.
%-----------------------------------------------------------------------------%
@@ -2091,6 +2153,191 @@
extra_attribute_to_string(backend(high_level_backend)) = "high_level_backend".
extra_attribute_to_string(max_stack_size(Size)) =
"max_stack_size(" ++ string__int_to_string(Size) ++ ")".
+
+%-----------------------------------------------------------------------------%
+%
+% Purity
+%
+
+less_pure(P1, P2) :-
+ \+ ( worst_purity(P1, P2) = P2).
+
+% worst_purity/3 could be written more compactly, but this definition
+% guarantees us a determinism error if we add to type `purity'. We also
+% define less_pure/2 in terms of worst_purity/3 rather than the other way
+% around for the same reason.
+
+worst_purity(purity_pure, purity_pure) = purity_pure.
+worst_purity(purity_pure, purity_semipure) = purity_semipure.
+worst_purity(purity_pure, purity_impure) = purity_impure.
+worst_purity(purity_semipure, purity_pure) = purity_semipure.
+worst_purity(purity_semipure, purity_semipure) = purity_semipure.
+worst_purity(purity_semipure, purity_impure) = purity_impure.
+worst_purity(purity_impure, purity_pure) = purity_impure.
+worst_purity(purity_impure, purity_semipure) = purity_impure.
+worst_purity(purity_impure, purity_impure) = purity_impure.
+
+% best_purity/3 is written as a switch for the same reason as worst_purity/3.
+
+best_purity(purity_pure, purity_pure) = purity_pure.
+best_purity(purity_pure, purity_semipure) = purity_pure.
+best_purity(purity_pure, purity_impure) = purity_pure.
+best_purity(purity_semipure, purity_pure) = purity_pure.
+best_purity(purity_semipure, purity_semipure) = purity_semipure.
+best_purity(purity_semipure, purity_impure) = purity_semipure.
+best_purity(purity_impure, purity_pure) = purity_pure.
+best_purity(purity_impure, purity_semipure) = purity_semipure.
+best_purity(purity_impure, purity_impure) = purity_impure.
+
+%-----------------------------------------------------------------------------%
+%
+% Determinism
+%
+
+determinism_components(det, cannot_fail, at_most_one).
+determinism_components(semidet, can_fail, at_most_one).
+determinism_components(multidet, cannot_fail, at_most_many).
+determinism_components(nondet, can_fail, at_most_many).
+determinism_components(cc_multidet, cannot_fail, at_most_many_cc).
+determinism_components(cc_nondet, can_fail, at_most_many_cc).
+determinism_components(erroneous, cannot_fail, at_most_zero).
+determinism_components(failure, can_fail, at_most_zero).
+
+det_conjunction_detism(DetismA, DetismB, Detism) :-
+ % When figuring out the determinism of a conjunction, if the second goal
+ % is unreachable, then then the determinism of the conjunction is just
+ % the determinism of the first goal.
+
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ ( MaxSolnA = at_most_zero ->
+ Detism = DetismA
+ ;
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_conjunction_canfail(CanFailA, CanFailB, CanFail),
+ det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln)
+ ).
+
+det_par_conjunction_detism(DetismA, DetismB, Detism) :-
+ % Figuring out the determinism of a parallel conjunction is much easier
+ % than for a sequential conjunction, since you simply ignore the case
+ % where the second goal is unreachable. Just do a normal solution count.
+
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_conjunction_canfail(CanFailA, CanFailB, CanFail),
+ det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln).
+
+det_switch_detism(DetismA, DetismB, Detism) :-
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_switch_canfail(CanFailA, CanFailB, CanFail),
+ det_switch_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln).
+
+%-----------------------------------------------------------------------------%
+%
+% The predicates in this section do abstract interpretation to count
+% the number of solutions and the possible number of failures.
+%
+% If the num_solns is at_most_many_cc, this means that the goal might have
+% many logical solutions if there were no pruning, but that the goal occurs
+% in a single-solution context, so only the first solution will be
+% returned.
+%
+% The reason why we don't throw an exception in det_switch_maxsoln and
+% det_disjunction_maxsoln is given in the documentation of the test case
+% invalid/magicbox.m.
+
+det_conjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_one, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_many, at_most_zero).
+
+det_conjunction_maxsoln(at_most_one, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_one, at_most_one, at_most_one).
+det_conjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_conjunction_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_conjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_conjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_conjunction_maxsoln(at_most_many_cc, at_most_many, _) :-
+ % If the first conjunct could be cc pruned, the second conj ought to have
+ % been cc pruned too.
+ error("det_conjunction_maxsoln: many_cc , many").
+
+det_conjunction_maxsoln(at_most_many, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_many, at_most_one, at_most_many).
+det_conjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many).
+det_conjunction_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_conjunction_canfail(can_fail, can_fail, can_fail).
+det_conjunction_canfail(can_fail, cannot_fail, can_fail).
+det_conjunction_canfail(cannot_fail, can_fail, can_fail).
+det_conjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_disjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_disjunction_maxsoln(at_most_zero, at_most_one, at_most_one).
+det_disjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_zero, at_most_many, at_most_many).
+
+det_disjunction_maxsoln(at_most_one, at_most_zero, at_most_one).
+det_disjunction_maxsoln(at_most_one, at_most_one, at_most_many).
+det_disjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_disjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
+
+det_disjunction_maxsoln(at_most_many, at_most_zero, at_most_many).
+det_disjunction_maxsoln(at_most_many, at_most_one, at_most_many).
+det_disjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_disjunction_canfail(can_fail, can_fail, can_fail).
+det_disjunction_canfail(can_fail, cannot_fail, cannot_fail).
+det_disjunction_canfail(cannot_fail, can_fail, cannot_fail).
+det_disjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_switch_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_switch_maxsoln(at_most_zero, at_most_one, at_most_one).
+det_switch_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_zero, at_most_many, at_most_many).
+
+det_switch_maxsoln(at_most_one, at_most_zero, at_most_one).
+det_switch_maxsoln(at_most_one, at_most_one, at_most_one).
+det_switch_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_switch_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
+
+det_switch_maxsoln(at_most_many, at_most_zero, at_most_many).
+det_switch_maxsoln(at_most_many, at_most_one, at_most_many).
+det_switch_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_switch_canfail(can_fail, can_fail, can_fail).
+det_switch_canfail(can_fail, cannot_fail, can_fail).
+det_switch_canfail(cannot_fail, can_fail, can_fail).
+det_switch_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_negation_det(det, yes(failure)).
+det_negation_det(semidet, yes(semidet)).
+det_negation_det(multidet, no).
+det_negation_det(nondet, no).
+det_negation_det(cc_multidet, no).
+det_negation_det(cc_nondet, no).
+det_negation_det(erroneous, yes(erroneous)).
+det_negation_det(failure, yes(det)).
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.39
diff -u -b -r1.39 prog_rep.m
--- compiler/prog_rep.m 28 Oct 2005 02:10:31 -0000 1.39
+++ compiler/prog_rep.m 1 Nov 2005 05:10:57 -0000
@@ -22,7 +22,6 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
:- import_module hlds.instmap.
:- import_module ll_backend.stack_layout.
:- import_module parse_tree.prog_data.
@@ -53,6 +52,7 @@
:- import_module check_hlds.mode_util.
:- import_module hlds.code_model.
:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_out.
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.11
diff -u -b -r1.11 prog_type.m
--- compiler/prog_type.m 28 Oct 2005 02:10:31 -0000 1.11
+++ compiler/prog_type.m 1 Nov 2005 05:28:30 -0000
@@ -8,8 +8,9 @@
%
% Main author: fjh
%
-% Utility predicates dealing with types that do not require access to the
-% HLDS. (The predicates that do are in type_util.m.)
+% Utility predicates dealing with type in the parse tree. The predicates for
+% doing type substitutions are in prog_type_subst.m, while utility predicates
+% for dealing with types in the HLDS are in type_util.m.
%
%-----------------------------------------------------------------------------%
@@ -17,10 +18,15 @@
:- interface.
+:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
+:- import_module bool.
:- import_module list.
+:- import_module map.
+:- import_module std_util.
+:- import_module term.
%-----------------------------------------------------------------------------%
%
@@ -108,30 +114,25 @@
%
:- pred type_ctor_is_tuple(type_ctor::in) is semidet.
- % type_ctor_is_variable(TypeCtor) succeeds iff TypeCtor is a variable.
- %
-:- pred type_ctor_is_variable(type_ctor::in) is semidet.
-
- % Convert a list of types to a list of vars. Fail if any of them are
+ % Convert a list of types to a list of vars. Fail if any of the type are
% not variables.
%
-:- pred prog_type.type_list_to_var_list(list(mer_type)::in, list(tvar)::out)
- is semidet.
+:- pred type_list_to_var_list(list(mer_type)::in, list(tvar)::out) is semidet.
% Convert a list of vars into a list of variable types.
%
-:- pred prog_type.var_list_to_type_list(tvar_kind_map::in, list(tvar)::in,
+:- pred var_list_to_type_list(tvar_kind_map::in, list(tvar)::in,
list(mer_type)::out) is det.
% Return a list of the type variables of a type, in order of their
% first occurrence in a depth-first, left-right traversal.
%
-:- pred prog_type.vars(mer_type::in, list(tvar)::out) is det.
+:- pred vars(mer_type::in, list(tvar)::out) is det.
% Return a list of the type variables of a list of types, in order
% of their first occurrence in a depth-first, left-right traversal.
%
-:- pred prog_type.vars_list(list(mer_type)::in, list(tvar)::out) is det.
+:- pred vars_list(list(mer_type)::in, list(tvar)::out) is det.
% Nondeterministically return the variables in a type.
%
@@ -164,105 +165,248 @@
:- pred strip_builtin_qualifiers_from_type_list(list(mer_type)::in,
list(mer_type)::out) is det.
-%-----------------------------------------------------------------------------%
-%
-% Type substitutions.
-%
-
-:- pred apply_rec_subst_to_type(tsubst::in, mer_type::in, mer_type::out)
+ % Return the list of type variables contained in a list of constraints.
+ %
+:- pred constraint_list_get_tvars(list(prog_constraint)::in, list(tvar)::out)
is det.
-:- pred apply_rec_subst_to_type_list(tsubst::in, list(mer_type)::in,
- list(mer_type)::out) is det.
-
-:- pred apply_rec_subst_to_tvar(tvar_kind_map::in, tsubst::in,
- tvar::in, mer_type::out) is det.
-
-:- pred apply_rec_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
- list(tvar)::in, list(mer_type)::out) is det.
-
-:- pred apply_subst_to_type(tsubst::in, mer_type::in, mer_type::out) is det.
-
-:- pred apply_subst_to_type_list(tsubst::in, list(mer_type)::in,
- list(mer_type)::out) is det.
-
-:- pred apply_subst_to_tvar(tvar_kind_map::in, tsubst::in,
- tvar::in, mer_type::out) is det.
-
-:- pred apply_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
- list(tvar)::in, list(mer_type)::out) is det.
-
-:- pred apply_variable_renaming_to_type(tvar_renaming::in, mer_type::in,
- mer_type::out) is det.
-
-:- pred apply_variable_renaming_to_type_list(tvar_renaming::in,
- list(mer_type)::in, list(mer_type)::out) is det.
-
-:- pred apply_variable_renaming_to_tvar(tvar_renaming::in, tvar::in, tvar::out)
- is det.
+ % Return the list of type variables contained in a constraint.
+ %
+:- pred constraint_get_tvars(prog_constraint::in, list(tvar)::out) is det.
-:- pred apply_variable_renaming_to_tvar_list(tvar_renaming::in, list(tvar)::in,
+:- pred get_unconstrained_tvars(list(tvar)::in, list(prog_constraint)::in,
list(tvar)::out) is det.
-:- pred apply_variable_renaming_to_tvar_kind_map(tvar_renaming::in,
- tvar_kind_map::in, tvar_kind_map::out) is det.
-
%-----------------------------------------------------------------------------%
-%
-% Utility predicates dealing with typeclass constraints.
-%
-
-:- pred apply_rec_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
- prog_constraints::out) is det.
-:- pred apply_rec_subst_to_prog_constraint_list(tsubst::in,
- list(prog_constraint)::in, list(prog_constraint)::out) is det.
+ % The list of type_ctors which are builtins which do not have a
+ % hlds_type_defn.
+ %
+:- func builtin_type_ctors_with_no_hlds_type_defn = list(type_ctor).
-:- pred apply_rec_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
- prog_constraint::out) is det.
+ % is_builtin_dummy_argument_type(ModuleName, TypeName, TypeArity):
+ %
+ % Is the given type a dummy type irrespective of its definition?
+ %
+:- pred is_builtin_dummy_argument_type(string::in, string::in, arity::in)
+ is semidet.
-:- pred apply_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
- prog_constraints::out) is det.
+ % Certain types, e.g. io.state and store.store(S), are just dummy types
+ % used to ensure logical semantics; there is no need to actually pass them,
+ % and so when importing or exporting procedures to/from C, we don't include
+ % arguments with these types.
+ %
+ % A type is a dummy type in one of two cases: either it is a builtin
+ % dummy type, or it has only a single function symbol of arity zero.
+ %
+:- pred constructor_list_represents_dummy_argument_type(list(constructor)::in,
+ maybe(unify_compare)::in) is semidet.
-:- pred apply_subst_to_prog_constraint_list(tsubst::in,
- list(prog_constraint)::in, list(prog_constraint)::out) is det.
+:- pred type_is_io_state(mer_type::in) is semidet.
-:- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
- prog_constraint::out) is det.
+:- pred type_is_aditi_state(mer_type::in) is semidet.
-:- pred apply_variable_renaming_to_prog_constraints(tvar_renaming::in,
- prog_constraints::in, prog_constraints::out) is det.
+:- pred type_ctor_is_array(type_ctor::in) is semidet.
-:- pred apply_variable_renaming_to_prog_constraint_list(tvar_renaming::in,
- list(prog_constraint)::in, list(prog_constraint)::out) is det.
+ % Remove an `aditi:state' from the given list if one is present.
+ %
+:- pred remove_aditi_state(list(mer_type)::in, list(T)::in, list(T)::out)
+ is det.
-:- pred apply_variable_renaming_to_prog_constraint(tvar_renaming::in,
- prog_constraint::in, prog_constraint::out) is det.
+ % A test for type_info-related types that are introduced by
+ % polymorphism.m. These need to be handled specially in certain
+ % places. For example, mode inference never infers unique modes
+ % for these types, since it would not be useful, and since we
+ % want to minimize the number of different modes that we infer.
+ %
+:- pred is_introduced_type_info_type(mer_type::in) is semidet.
+
+:- pred is_introduced_type_info_type_ctor(type_ctor::in) is semidet.
+
+:- func is_introduced_type_info_type_category(type_category) = bool.
+
+ % Given a list of variables, return the permutation
+ % of that list which has all the type_info-related variables
+ % preceding the non-type_info-related variables (with the relative
+ % order of variables within each group being the same as in the
+ % original list).
+ %
+:- func put_typeinfo_vars_first(list(prog_var), vartypes) = list(prog_var).
+
+ % In the forwards mode, this predicate checks for a "new " prefix
+ % at the start of the functor name, and removes it if present;
+ % it fails if there is no such prefix.
+ % In the reverse mode, this predicate prepends such a prefix.
+ % (These prefixes are used for construction unifications
+ % with existentially typed functors.)
+ %
+:- pred remove_new_prefix(sym_name, sym_name).
+:- mode remove_new_prefix(in, out) is semidet.
+:- mode remove_new_prefix(out, in) is det.
+
+:- type type_category
+ ---> type_cat_int
+ ; type_cat_char
+ ; type_cat_string
+ ; type_cat_float
+ ; type_cat_higher_order
+ ; type_cat_tuple
+ ; type_cat_enum
+ ; type_cat_dummy
+ ; type_cat_variable
+ ; type_cat_type_info
+ ; type_cat_type_ctor_info
+ ; type_cat_typeclass_info
+ ; type_cat_base_typeclass_info
+ ; type_cat_void
+ ; type_cat_user_ctor.
+
+ % Construct builtin types.
+ %
+:- func int_type = mer_type.
+:- func string_type = mer_type.
+:- func float_type = mer_type.
+:- func char_type = mer_type.
+:- func void_type = mer_type.
+:- func c_pointer_type = mer_type.
+:- func heap_pointer_type = mer_type.
+:- func sample_type_info_type = mer_type.
+:- func sample_typeclass_info_type = mer_type.
+:- func comparison_result_type = mer_type.
+:- func aditi_state_type = mer_type.
+
+ % Construct the types of type_infos and type_ctor_infos.
+ %
+:- func type_info_type = mer_type.
+:- func type_ctor_info_type = mer_type.
+
+ % Given a constant and an arity, return a type_ctor.
+ % Fails if the constant is not an atom.
+ %
+:- pred make_type_ctor(const::in, int::in, type_ctor::out) is semidet.
+
+:- type polymorphism_cell
+ ---> type_info_cell(type_ctor)
+ ; typeclass_info_cell.
+
+:- func cell_cons_id(polymorphism_cell) = cons_id.
+
+:- func cell_inst_cons_id(polymorphism_cell, int) = cons_id.
+
+ % Module-qualify the cons_id using module information from the type.
+ % The second output value is the cons_id required for use in insts which
+ % can be different from that used in types for typeclass_info and
+ % type_info. The list(prog_var) is the list of arguments to the cons_id
+ % and is just used for obtaining the arity for typeclass_info and type_info
+ % cons_ids.
+ %
+:- pred qualify_cons_id(mer_type::in, list(prog_var)::in, cons_id::in,
+ cons_id::out, cons_id::out) is det.
+
+ % This type is used to return information about a constructor definition,
+ % extracted from the hlds_type_defn and hlds_cons_defn data types.
+ %
+:- type ctor_defn
+ ---> ctor_defn(
+ ctor_tvars :: tvarset,
+ ctor_existq_tvars :: existq_tvars,
+ ctor_tvar_kinds :: tvar_kind_map,
+ % kinds of existq_tvars
+ ctor_constraints :: list(prog_constraint),
+ % existential constraints
+ ctor_arg_types :: list(mer_type),
+ % functor argument types
+ ctor_result_type :: mer_type
+ % functor result type
+ ).
+
+ % Check whether the type with the given list of constructors would be
+ % a no_tag type (which requires the list to include exactly one constructor
+ % with exactly one argument), and if so, return its constructor symbol,
+ % argument type, and the argument's name (if it has one).
+ %
+ % This doesn't do any checks for options that might be set (such as
+ % turning off no_tag_types). If you want those checks you should use
+ % type_is_no_tag_type/4, or if you really know what you are doing,
+ % perform the checks yourself.
+ %
+:- pred type_constructors_are_no_tag_type(list(constructor)::in, sym_name::out,
+ mer_type::out, maybe(string)::out) is semidet.
+
+ % Given a list of constructors for a type, check whether that type
+ % is a private_builtin.type_info/0 or similar type.
+ %
+:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
+
+ % type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReservedTag,
+ % Ctors, UserEqComp, FunctorName, FunctorArgType, MaybeFunctorArgName):
+ %
+ % Check whether some constructors are a no_tag type, and that this
+ % is compatible with the ReservedTag setting for this type and
+ % the grade options set in the globals.
+ % Assign single functor of arity one a `no_tag' tag (unless we are
+ % reserving a tag, or if it is one of the dummy types).
+ %
+:- pred type_with_constructors_should_be_no_tag(globals::in, type_ctor::in,
+ bool::in, list(constructor)::in, maybe(unify_compare)::in, sym_name::out,
+ mer_type::out, maybe(string)::out) is semidet.
+
+ % Unify (with occurs check) two types with respect to a type substitution
+ % and update the type bindings. The third argument is a list of type
+ % variables which cannot be bound (i.e. head type variables).
+ %
+ % No kind checking is done, since it is assumed that kind errors
+ % will be picked up elsewhere.
+ %
+:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, tsubst::in,
+ tsubst::out) is semidet.
+
+:- pred type_unify_list(list(mer_type)::in, list(mer_type)::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+ % type_list_subsumes(TypesA, TypesB, Subst) succeeds iff the list
+ % TypesA subsumes (is more general than) TypesB, producing a
+ % type substitution which when applied to TypesA will give TypesB.
+ %
+:- pred type_list_subsumes(list(mer_type)::in, list(mer_type)::in, tsubst::out)
+ is semidet.
- % Return the list of type variables contained in a list of constraints.
+ % This does the same as type_list_subsumes, but aborts instead of failing.
%
-:- pred constraint_list_get_tvars(list(prog_constraint)::in, list(tvar)::out)
- is det.
+:- pred type_list_subsumes_det(list(mer_type)::in, list(mer_type)::in,
+ tsubst::out) is det.
- % Return the list of type variables contained in a constraint.
+ % arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
+ % CalleeExistQVars, CalleeArgTypes):
%
-:- pred constraint_get_tvars(prog_constraint::in, list(tvar)::out) is det.
+ % Check that the argument types of the called predicate, function or
+ % constructor subsume the types of the arguments of the call. This checks
+ % that none of the existentially quantified type variables of the callee
+ % are bound.
+ %
+:- pred arg_type_list_subsumes(tvarset::in, list(mer_type)::in, tvarset::in,
+ tvar_kind_map::in, existq_tvars::in, list(mer_type)::in) is semidet.
-:- pred get_unconstrained_tvars(list(tvar)::in, list(prog_constraint)::in,
- list(tvar)::out) is det.
+ % Apply a renaming (partial map) to a list.
+ % Useful for applying a variable renaming to a list of variables.
+ %
+:- pred apply_partial_map_to_list(map(T, T)::in, list(T)::in, list(T)::out)
+ is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
+:- import_module libs.options.
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
+:- import_module parse_tree.prog_type_subst.
-:- import_module map.
-:- import_module std_util.
+:- import_module require.
+:- import_module string.
:- import_module svmap.
%-----------------------------------------------------------------------------%
@@ -319,16 +463,11 @@
).
type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) :-
- (
- type_is_higher_order(Type, _Purity, PredOrFunc, _,
- TypeArgs0)
- ->
+ ( type_is_higher_order(Type, _Purity, PredOrFunc, _, TypeArgs0) ->
TypeArgs = TypeArgs0,
PredOrFuncStr = prog_out.pred_or_func_to_str(PredOrFunc),
TypeCtor = unqualified(PredOrFuncStr) - 0
- ;
- type_is_tuple(Type, TypeArgs1)
- ->
+ ; type_is_tuple(Type, TypeArgs1) ->
TypeArgs = TypeArgs1,
% XXX why tuple/0 and not {}/N ?
TypeCtor = unqualified("tuple") - 0
@@ -415,58 +554,56 @@
type_ctor_is_tuple(unqualified("{}") - _).
-type_ctor_is_variable(unqualified("") - _).
-
-prog_type.type_list_to_var_list([], []).
-prog_type.type_list_to_var_list([Type | Types], [Var | Vars]) :-
+type_list_to_var_list([], []).
+type_list_to_var_list([Type | Types], [Var | Vars]) :-
Type = variable(Var, _),
- prog_type.type_list_to_var_list(Types, Vars).
+ type_list_to_var_list(Types, Vars).
-prog_type.var_list_to_type_list(_, [], []).
-prog_type.var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :-
+var_list_to_type_list(_, [], []).
+var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :-
get_tvar_kind(KindMap, Var, Kind),
Type = variable(Var, Kind),
- prog_type.var_list_to_type_list(KindMap, Vars, Types).
+ var_list_to_type_list(KindMap, Vars, Types).
-prog_type.vars(Type, TVars) :-
- prog_type.vars_2(Type, [], RevTVars),
+vars(Type, TVars) :-
+ vars_2(Type, [], RevTVars),
list.reverse(RevTVars, TVarsDups),
list.remove_dups(TVarsDups, TVars).
-:- pred prog_type.vars_2(mer_type::in, list(tvar)::in, list(tvar)::out) is det.
+:- pred vars_2(mer_type::in, list(tvar)::in, list(tvar)::out) is det.
-prog_type.vars_2(variable(Var, _), Vs, [Var | Vs]).
-prog_type.vars_2(defined(_, Args, _), !V) :-
- prog_type.vars_list_2(Args, !V).
-prog_type.vars_2(builtin(_), !V).
-prog_type.vars_2(higher_order(Args, MaybeRet, _, _), !V) :-
- prog_type.vars_list_2(Args, !V),
+vars_2(variable(Var, _), Vs, [Var | Vs]).
+vars_2(defined(_, Args, _), !V) :-
+ vars_list_2(Args, !V).
+vars_2(builtin(_), !V).
+vars_2(higher_order(Args, MaybeRet, _, _), !V) :-
+ vars_list_2(Args, !V),
(
MaybeRet = yes(Ret),
- prog_type.vars_2(Ret, !V)
+ vars_2(Ret, !V)
;
MaybeRet = no
).
-prog_type.vars_2(tuple(Args, _), !V) :-
- prog_type.vars_list_2(Args, !V).
-prog_type.vars_2(apply_n(Var, Args, _), !V) :-
+vars_2(tuple(Args, _), !V) :-
+ vars_list_2(Args, !V).
+vars_2(apply_n(Var, Args, _), !V) :-
!:V = [Var | !.V],
- prog_type.vars_list_2(Args, !V).
-prog_type.vars_2(kinded(Type, _), !V) :-
- prog_type.vars_2(Type, !V).
+ vars_list_2(Args, !V).
+vars_2(kinded(Type, _), !V) :-
+ vars_2(Type, !V).
-prog_type.vars_list(Types, TVars) :-
- prog_type.vars_list_2(Types, [], RevTVars),
+vars_list(Types, TVars) :-
+ vars_list_2(Types, [], RevTVars),
list.reverse(RevTVars, TVarsDups),
list.remove_dups(TVarsDups, TVars).
-:- pred prog_type.vars_list_2(list(mer_type)::in, list(tvar)::in,
- list(tvar)::out) is det.
+:- pred vars_list_2(list(mer_type)::in, list(tvar)::in, list(tvar)::out)
+ is det.
-prog_type.vars_list_2([], !V).
-prog_type.vars_list_2([Type | Types], !V) :-
- prog_type.vars_2(Type, !V),
- prog_type.vars_list_2(Types, !V).
+vars_list_2([], !V).
+vars_list_2([Type | Types], !V) :-
+ vars_2(Type, !V),
+ vars_list_2(Types, !V).
type_contains_var(variable(Var, _), Var).
type_contains_var(defined(_, Args, _), Var) :-
@@ -565,268 +702,629 @@
%-----------------------------------------------------------------------------%
-apply_rec_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
- ( map__search(Subst, TVar, Type1) ->
- ensure_type_has_kind(Kind, Type1, Type2),
- apply_rec_subst_to_type(Subst, Type2, Type)
+constraint_list_get_tvars(Constraints, TVars) :-
+ list.map(constraint_get_tvars, Constraints, TVarsList),
+ list.condense(TVarsList, TVars).
+
+constraint_get_tvars(constraint(_Name, Args), TVars) :-
+ vars_list(Args, TVars).
+
+get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :-
+ constraint_list_get_tvars(Constraints, ConstrainedTvars),
+ list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0),
+ list.remove_dups(Unconstrained0, Unconstrained).
+
+%-----------------------------------------------------------------------------%
+
+builtin_type_ctors_with_no_hlds_type_defn =
+ [ qualified(mercury_public_builtin_module, "int") - 0,
+ qualified(mercury_public_builtin_module, "string") - 0,
+ qualified(mercury_public_builtin_module, "character") - 0,
+ qualified(mercury_public_builtin_module, "float") - 0,
+ qualified(mercury_public_builtin_module, "pred") - 0,
+ qualified(mercury_public_builtin_module, "func") - 0,
+ qualified(mercury_public_builtin_module, "void") - 0,
+ qualified(mercury_public_builtin_module, "tuple") - 0
+ ].
+
+is_builtin_dummy_argument_type("io", "state", 0). % io.state/0
+is_builtin_dummy_argument_type("store", "store", 1). % store.store/1.
+% XXX should we include aditi.state/0 in this list?
+
+constructor_list_represents_dummy_argument_type([Ctor], no) :-
+ Ctor = ctor([], [], _, []).
+
+type_is_io_state(Type) :-
+ type_to_ctor_and_args(Type, TypeCtor, []),
+ TypeCtor = qualified(unqualified("io"), "state") - 0.
+
+type_is_aditi_state(Type) :-
+ type_to_ctor_and_args(Type, TypeCtor, []),
+ TypeCtor = qualified(unqualified("aditi"), "state") - 0.
+
+type_ctor_is_array(qualified(unqualified("array"), "array") - 1).
+
+remove_aditi_state([], [], []).
+remove_aditi_state([], [_ | _], _) :-
+ error("gremove_aditi_state").
+remove_aditi_state([_ | _], [], _) :-
+ error("gremove_aditi_state").
+remove_aditi_state([Type | Types], [Arg | Args0], Args) :-
+ ( type_is_aditi_state(Type) ->
+ remove_aditi_state(Types, Args0, Args)
+ ;
+ remove_aditi_state(Types, Args0, Args1),
+ Args = [Arg | Args1]
+ ).
+
+is_introduced_type_info_type(Type) :-
+ type_to_ctor_and_args(Type, TypeCtor, _),
+ is_introduced_type_info_type_ctor(TypeCtor).
+
+is_introduced_type_info_type_ctor(TypeCtor) :-
+ TypeCtor = qualified(PrivateBuiltin, Name) - 0,
+ mercury_private_builtin_module(PrivateBuiltin),
+ ( Name = "type_info"
+ ; Name = "type_ctor_info"
+ ; Name = "typeclass_info"
+ ; Name = "base_typeclass_info"
+ ).
+
+is_introduced_type_info_type_category(type_cat_int) = no.
+is_introduced_type_info_type_category(type_cat_char) = no.
+is_introduced_type_info_type_category(type_cat_string) = no.
+is_introduced_type_info_type_category(type_cat_float) = no.
+is_introduced_type_info_type_category(type_cat_higher_order) = no.
+is_introduced_type_info_type_category(type_cat_tuple) = no.
+is_introduced_type_info_type_category(type_cat_enum) = no.
+is_introduced_type_info_type_category(type_cat_dummy) = no.
+is_introduced_type_info_type_category(type_cat_variable) = no.
+is_introduced_type_info_type_category(type_cat_type_info) = yes.
+is_introduced_type_info_type_category(type_cat_type_ctor_info) = yes.
+is_introduced_type_info_type_category(type_cat_typeclass_info) = yes.
+is_introduced_type_info_type_category(type_cat_base_typeclass_info) = yes.
+is_introduced_type_info_type_category(type_cat_void) = no.
+is_introduced_type_info_type_category(type_cat_user_ctor) = no.
+
+%-----------------------------------------------------------------------------%
+
+put_typeinfo_vars_first(VarsList, VarTypes) =
+ TypeInfoVarsList ++ NonTypeInfoVarsList :-
+ list__filter((pred(Var::in) is semidet :-
+ Type = map__lookup(VarTypes, Var),
+ is_introduced_type_info_type(Type)),
+ VarsList, TypeInfoVarsList, NonTypeInfoVarsList).
+
+remove_new_prefix(unqualified(Name0), unqualified(Name)) :-
+ string__append("new ", Name, Name0).
+remove_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :-
+ string__append("new ", Name, Name0).
+
+%-----------------------------------------------------------------------------%
+
+int_type = builtin(int).
+
+string_type = builtin(string).
+
+float_type = builtin(float).
+
+char_type = builtin(character).
+
+void_type = defined(unqualified("void"), [], star).
+
+c_pointer_type = defined(Name, [], star) :-
+ mercury_public_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "c_pointer").
+
+heap_pointer_type = defined(Name, [], star) :-
+ mercury_private_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "heap_pointer").
+
+sample_type_info_type = defined(Name, [], star) :-
+ mercury_private_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "sample_type_info").
+
+sample_typeclass_info_type = defined(Name, [], star) :-
+ mercury_private_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "sample_typeclass_info").
+
+comparison_result_type = defined(Name, [], star) :-
+ mercury_public_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "comparison_result").
+
+type_info_type = defined(Name, [], star) :-
+ mercury_private_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "type_info").
+
+type_ctor_info_type = defined(Name, [], star) :-
+ mercury_private_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "type_ctor_info").
+
+aditi_state_type = defined(Name, [], star) :-
+ aditi_public_builtin_module(BuiltinModule),
+ Name = qualified(BuiltinModule, "state").
+
+%-----------------------------------------------------------------------------%
+
+ % Given a constant and an arity, return a type_ctor.
+ % This really ought to take a name and an arity -
+ % use of integers/floats/strings as type names should
+ % be rejected by the parser in prog_io.m, not in module_qual.m.
+
+make_type_ctor(term__atom(Name), Arity, unqualified(Name) - Arity).
+
+%-----------------------------------------------------------------------------%
+
+cell_cons_id(type_info_cell(Ctor)) = type_info_cell_constructor(Ctor).
+cell_cons_id(typeclass_info_cell) = typeclass_info_cell_constructor.
+
+cell_inst_cons_id(Which, Arity) = InstConsId :-
+ % Neither of these function symbols exist, even with fake arity,
+ % but they do not need to.
+ (
+ Which = type_info_cell(_),
+ Symbol = "type_info"
;
- Type = Type0
+ Which = typeclass_info_cell,
+ Symbol = "typeclass_info"
+ ),
+ PrivateBuiltin = mercury_private_builtin_module,
+ InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity).
+
+%-----------------------------------------------------------------------------%
+
+qualify_cons_id(Type, Args, ConsId0, ConsId, InstConsId) :-
+ (
+ ConsId0 = cons(Name0, OrigArity),
+ type_to_ctor_and_args(Type, TypeCtor, _),
+ TypeCtor = qualified(TypeModule, _) - _
+ ->
+ unqualify_name(Name0, UnqualName),
+ Name = qualified(TypeModule, UnqualName),
+ ConsId = cons(Name, OrigArity),
+ InstConsId = ConsId
+ ;
+ ConsId0 = type_info_cell_constructor(CellCtor)
+ ->
+ ConsId = ConsId0,
+ InstConsId = cell_inst_cons_id(type_info_cell(CellCtor),
+ list__length(Args))
+ ;
+ ConsId0 = typeclass_info_cell_constructor
+ ->
+ ConsId = typeclass_info_cell_constructor,
+ InstConsId = cell_inst_cons_id(typeclass_info_cell, list__length(Args))
+ ;
+ ConsId = ConsId0,
+ InstConsId = ConsId
).
-apply_rec_subst_to_type(Subst, defined(Name, Args0, Kind),
- defined(Name, Args, Kind)) :-
- apply_rec_subst_to_type_list(Subst, Args0, Args).
-apply_rec_subst_to_type(_Subst, Type @ builtin(_), Type).
-apply_rec_subst_to_type(Subst,
- higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
- higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
- apply_rec_subst_to_type_list(Subst, Args0, Args),
- (
- MaybeReturn0 = yes(Return0),
- apply_rec_subst_to_type(Subst, Return0, Return),
- MaybeReturn = yes(Return)
- ;
- MaybeReturn0 = no,
- MaybeReturn = no
- ).
-apply_rec_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
- apply_rec_subst_to_type_list(Subst, Args0, Args).
-apply_rec_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
- apply_rec_subst_to_type_list(Subst, Args0, Args),
- ( map__search(Subst, TVar, AppliedType0) ->
- apply_rec_subst_to_type(Subst, AppliedType0, AppliedType),
- apply_type_args(AppliedType, Args, Type)
- ;
- Type = apply_n(TVar, Args, Kind)
- ).
-apply_rec_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
- apply_rec_subst_to_type(Subst, Type0, Type).
-
-apply_rec_subst_to_type_list(Subst, Types0, Types) :-
- list__map(apply_rec_subst_to_type(Subst), Types0, Types).
-
-apply_rec_subst_to_tvar(KindMap, Subst, TVar, Type) :-
- ( map__search(Subst, TVar, Type0) ->
- apply_rec_subst_to_type(Subst, Type0, Type)
- ;
- get_tvar_kind(KindMap, TVar, Kind),
- Type = variable(TVar, Kind)
- ).
-
-apply_rec_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
- list__map(apply_rec_subst_to_tvar(KindMap, Subst), TVars, Types).
-
-apply_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
- ( map__search(Subst, TVar, Type1) ->
- ensure_type_has_kind(Kind, Type1, Type)
+
+%-----------------------------------------------------------------------------%
+
+type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :-
+ type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName0, ArgType),
+
+ % We don't handle unary tuples as no_tag types -- they are rare enough
+ % that it's not worth the implementation effort.
+ Ctor \= unqualified("{}"),
+
+ map_maybe(unqualify_name, MaybeArgName0, MaybeArgName).
+
+type_constructors_are_type_info(Ctors) :-
+ type_is_single_ctor_single_arg(Ctors, Ctor, _, _),
+ ctor_is_type_info(Ctor).
+
+:- pred type_is_single_ctor_single_arg(list(constructor)::in, sym_name::out,
+ maybe(ctor_field_name)::out, mer_type::out) is semidet.
+
+type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :-
+ Ctors = [SingleCtor],
+ SingleCtor = ctor(ExistQVars, _Constraints, Ctor,
+ [MaybeArgName - ArgType]),
+ ExistQVars = [].
+
+:- pred ctor_is_type_info(sym_name::in) is semidet.
+
+ctor_is_type_info(Ctor) :-
+ unqualify_private_builtin(Ctor, Name),
+ name_is_type_info(Name).
+
+ % If the sym_name is in the private_builtin module, unqualify it,
+ % otherwise fail. All, user-defined types should be module-qualified
+ % by the time this predicate is called, so we assume that any unqualified
+ % names are in private_builtin.
+ %
+:- pred unqualify_private_builtin(sym_name::in, string::out) is semidet.
+
+unqualify_private_builtin(unqualified(Name), Name).
+unqualify_private_builtin(qualified(ModuleName, Name), Name) :-
+ mercury_private_builtin_module(ModuleName).
+
+:- pred name_is_type_info(string::in) is semidet.
+
+name_is_type_info("type_info").
+name_is_type_info("type_ctor_info").
+name_is_type_info("typeclass_info").
+name_is_type_info("base_typeclass_info").
+
+%-----------------------------------------------------------------------------%
+
+ % Assign single functor of arity one a `no_tag' tag (unless we are
+ % reserving a tag, or if it is one of the dummy types).
+ %
+type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReserveTagPragma,
+ Ctors, UserEqCmp, SingleFunc, SingleArg, MaybeArgName) :-
+ type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg,
+ MaybeArgName),
+ (
+ ReserveTagPragma = no,
+ globals__lookup_bool_option(Globals, reserve_tag, no),
+ globals__lookup_bool_option(Globals, unboxed_no_tag_types, yes)
+ ;
+ % Dummy types always need to be treated as no-tag types as the
+ % low-level C back end just passes around rubbish for them. When e.g.
+ % using the debugger, it is crucial that these values are treated
+ % as unboxed c_pointers, not as tagged pointers to c_pointers
+ % (otherwise the system winds up following a bogus pointer).
+ is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp)
+ ).
+
+:- pred is_dummy_argument_type_with_constructors(type_ctor::in,
+ list(constructor)::in, maybe(unify_compare)::in) is semidet.
+
+is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp) :-
+ % Keep this in sync with is_dummy_argument_type below.
+ (
+ TypeCtor = CtorSymName - TypeArity,
+ CtorSymName = qualified(unqualified(ModuleName), TypeName),
+ is_builtin_dummy_argument_type(ModuleName, TypeName, TypeArity)
;
- Type = Type0
+ constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
).
-apply_subst_to_type(Subst, defined(Name, Args0, Kind),
- defined(Name, Args, Kind)) :-
- apply_subst_to_type_list(Subst, Args0, Args).
-apply_subst_to_type(_Subst, Type @ builtin(_), Type).
-apply_subst_to_type(Subst,
- higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
- higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
- apply_subst_to_type_list(Subst, Args0, Args),
- (
- MaybeReturn0 = yes(Return0),
- apply_subst_to_type(Subst, Return0, Return),
- MaybeReturn = yes(Return)
- ;
- MaybeReturn0 = no,
- MaybeReturn = no
- ).
-apply_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
- apply_subst_to_type_list(Subst, Args0, Args).
-apply_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
- apply_subst_to_type_list(Subst, Args0, Args),
- ( map__search(Subst, TVar, AppliedType) ->
- apply_type_args(AppliedType, Args, Type)
- ;
- Type = apply_n(TVar, Args, Kind)
- ).
-apply_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
- apply_subst_to_type(Subst, Type0, Type).
-
-apply_subst_to_type_list(Subst, Types0, Types) :-
- list__map(apply_subst_to_type(Subst), Types0, Types).
-
-apply_subst_to_tvar(KindMap, Subst, TVar, Type) :-
- ( map__search(Subst, TVar, Type0) ->
- apply_subst_to_type(Subst, Type0, Type)
- ;
- get_tvar_kind(KindMap, TVar, Kind),
- Type = variable(TVar, Kind)
- ).
-
-apply_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
- list__map(apply_subst_to_tvar(KindMap, Subst), TVars, Types).
-
-apply_variable_renaming_to_type(Renaming, variable(TVar0, Kind),
- variable(TVar, Kind)) :-
- apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
-apply_variable_renaming_to_type(Renaming, defined(Name, Args0, Kind),
- defined(Name, Args, Kind)) :-
- apply_variable_renaming_to_type_list(Renaming, Args0, Args).
-apply_variable_renaming_to_type(_Renaming, Type @ builtin(_), Type).
-apply_variable_renaming_to_type(Renaming,
- higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
- higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
- apply_variable_renaming_to_type_list(Renaming, Args0, Args),
- (
- MaybeReturn0 = yes(Return0),
- apply_variable_renaming_to_type(Renaming, Return0, Return),
- MaybeReturn = yes(Return)
- ;
- MaybeReturn0 = no,
- MaybeReturn = no
- ).
-apply_variable_renaming_to_type(Renaming, tuple(Args0, Kind),
- tuple(Args, Kind)) :-
- apply_variable_renaming_to_type_list(Renaming, Args0, Args).
-apply_variable_renaming_to_type(Renaming, apply_n(TVar0, Args0, Kind),
- apply_n(TVar, Args, Kind)) :-
- apply_variable_renaming_to_type_list(Renaming, Args0, Args),
- apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
-apply_variable_renaming_to_type(Renaming, kinded(Type0, Kind),
- kinded(Type, Kind)) :-
- apply_variable_renaming_to_type(Renaming, Type0, Type).
-
-apply_variable_renaming_to_type_list(Renaming, Types0, Types) :-
- list__map(apply_variable_renaming_to_type(Renaming), Types0, Types).
-
-apply_variable_renaming_to_tvar(Renaming, TVar0, TVar) :-
- ( map__search(Renaming, TVar0, TVar1) ->
- TVar = TVar1
- ;
- TVar = TVar0
- ).
-
-apply_variable_renaming_to_tvar_list(Renaming, TVars0, TVars) :-
- list__map(apply_variable_renaming_to_tvar(Renaming), TVars0, TVars).
-
-apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap) :-
- map__foldl(apply_variable_renaming_to_tvar_kind_map_2(Renaming),
- KindMap0, map__init, KindMap).
-
-:- pred apply_variable_renaming_to_tvar_kind_map_2(tvar_renaming::in, tvar::in,
- kind::in, tvar_kind_map::in, tvar_kind_map::out) is det.
-
-apply_variable_renaming_to_tvar_kind_map_2(Renaming, TVar0, Kind, !KindMap) :-
- apply_variable_renaming_to_tvar(Renaming, TVar0, TVar),
- svmap__det_insert(TVar, Kind, !KindMap).
-:- pred apply_type_args(mer_type::in, list(mer_type)::in, mer_type::out)
- is det.
+%-----------------------------------------------------------------------------%
+%
+% Type unification.
+%
-apply_type_args(variable(TVar, Kind0), Args, apply_n(TVar, Args, Kind)) :-
- apply_type_args_to_kind(Kind0, Args, Kind).
-apply_type_args(defined(Name, Args0, Kind0), Args,
- defined(Name, Args0 ++ Args, Kind)) :-
- apply_type_args_to_kind(Kind0, Args, Kind).
-apply_type_args(Type @ builtin(_), [], Type).
-apply_type_args(builtin(_), [_ | _], _) :-
- unexpected(this_file, "applied type args to builtin").
-apply_type_args(Type @ higher_order(_, _, _, _), [], Type).
-apply_type_args(higher_order(_, _, _, _), [_ | _], _) :-
- unexpected(this_file, "applied type args to higher_order").
-apply_type_args(tuple(Args0, Kind0), Args, tuple(Args0 ++ Args, Kind)) :-
- apply_type_args_to_kind(Kind0, Args, Kind).
-apply_type_args(apply_n(TVar, Args0, Kind0), Args,
- apply_n(TVar, Args0 ++ Args, Kind)) :-
- apply_type_args_to_kind(Kind0, Args, Kind).
-apply_type_args(kinded(Type0, _), Args, Type) :-
- % We drop the explicit kind annotation, since:
- % - it will already have been used by kind inference, and
- % - it no longer corresponds to any explicit annotation given.
- apply_type_args(Type0, Args, Type).
+type_unify(X, Y, HeadTypeParams, !Bindings) :-
+ ( X = variable(VarX, _) ->
+ type_unify_var(VarX, Y, HeadTypeParams, !Bindings)
+ ; Y = variable(VarY, _) ->
+ type_unify_var(VarY, X, HeadTypeParams, !Bindings)
+ ; type_unify_nonvar(X, Y, HeadTypeParams, !Bindings) ->
+ true
+ ;
+ % Some special cases are not handled above. We handle them separately
+ % here.
+ type_unify_special(X, Y, HeadTypeParams, !Bindings)
+ ).
+
+:- pred type_unify_var(tvar::in, mer_type::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings) :-
+ ( TypeY = variable(VarY, KindY) ->
+ type_unify_var_var(VarX, VarY, KindY, HeadTypeParams, !Bindings)
+ ; map.search(!.Bindings, VarX, BindingOfX) ->
+ % VarX has a binding. Y is not a variable.
+ type_unify(BindingOfX, TypeY, HeadTypeParams, !Bindings)
+ ;
+ % VarX has no binding, so bind it to TypeY.
+ \+ type_occurs(TypeY, VarX, !.Bindings),
+ \+ list.member(VarX, HeadTypeParams),
+ svmap.det_insert(VarX, TypeY, !Bindings)
+ ).
+
+:- pred type_unify_var_var(tvar::in, tvar::in, kind::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_var_var(X, Y, Kind, HeadTypeParams, !Bindings) :-
+ ( list.member(Y, HeadTypeParams) ->
+ type_unify_head_type_param(X, Y, Kind, HeadTypeParams, !Bindings)
+ ; list.member(X, HeadTypeParams) ->
+ type_unify_head_type_param(Y, X, Kind, HeadTypeParams, !Bindings)
+ ; map.search(!.Bindings, X, BindingOfX) ->
+ ( map.search(!.Bindings, Y, BindingOfY) ->
+ % Both X and Y already have bindings - just unify the
+ % types they are bound to.
+ type_unify(BindingOfX, BindingOfY, HeadTypeParams, !Bindings)
+ ;
+ % Y hasn't been bound yet.
+ apply_rec_subst_to_type(!.Bindings, BindingOfX, SubstBindingOfX),
+ ( SubstBindingOfX = variable(Y, _) ->
+ true
+ ;
+ \+ type_occurs(SubstBindingOfX, Y, !.Bindings),
+ svmap.det_insert(Y, SubstBindingOfX, !Bindings)
+ )
+ )
+ ;
+ % Neither X nor Y is a head type param. X had not been bound yet.
+ ( map.search(!.Bindings, Y, BindingOfY) ->
+ apply_rec_subst_to_type(!.Bindings, BindingOfY, SubstBindingOfY),
+ ( SubstBindingOfY = variable(X, _) ->
+ true
+ ;
+ \+ type_occurs(SubstBindingOfY, X, !.Bindings),
+ svmap.det_insert(X, SubstBindingOfY, !Bindings)
+ )
+ ;
+ % Both X and Y are unbound type variables - bind one to the other.
+ ( X = Y ->
+ true
+ ;
+ svmap.det_insert(X, variable(Y, Kind), !Bindings)
+ )
+ )
+ ).
-:- pred apply_type_args_to_kind(kind::in, list(mer_type)::in, kind::out)
- is det.
+:- pred type_unify_head_type_param(tvar::in, tvar::in, kind::in,
+ list(tvar)::in, tsubst::in, tsubst::out) is semidet.
-apply_type_args_to_kind(Kind, [], Kind).
-apply_type_args_to_kind(star, [_ | _], _) :-
- unexpected(this_file, "too many args in apply_n").
-apply_type_args_to_kind(arrow(Kind0, Kind1), [ArgType | ArgTypes], Kind) :-
- ( get_type_kind(ArgType) = Kind0 ->
- apply_type_args_to_kind(Kind1, ArgTypes, Kind)
- ;
- unexpected(this_file, "kind error in apply_n")
+type_unify_head_type_param(Var, HeadVar, Kind, HeadTypeParams, !Bindings) :-
+ ( map.search(!.Bindings, Var, BindingOfVar) ->
+ BindingOfVar = variable(Var2, _),
+ type_unify_head_type_param(Var2, HeadVar, Kind, HeadTypeParams,
+ !Bindings)
+ ;
+ ( Var = HeadVar ->
+ true
+ ;
+ \+ list.member(Var, HeadTypeParams),
+ svmap.det_insert(Var, variable(HeadVar, Kind), !Bindings)
+ )
+ ).
+
+ % Unify two types, neither of which are variables. Two special cases
+ % which are not handled here are apply_n types and kinded types.
+ % Those are handled below.
+ %
+:- pred type_unify_nonvar(mer_type::in, mer_type::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_nonvar(defined(SymName, ArgsX, _), defined(SymName, ArgsY, _),
+ HeadTypeParams, !Bindings) :-
+ % Instead of insisting that the names are equal and the arg lists
+ % unify, we should consider attempting to expand equivalence types
+ % first. That would require the type table to be passed in to the
+ % unification algorithm, though.
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+type_unify_nonvar(builtin(BuiltinType), builtin(BuiltinType), _, !Bindings).
+type_unify_nonvar(higher_order(ArgsX, no, Purity, EvalMethod),
+ higher_order(ArgsY, no, Purity, EvalMethod),
+ HeadTypeParams, !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+type_unify_nonvar(higher_order(ArgsX, yes(RetX), Purity, EvalMethod),
+ higher_order(ArgsY, yes(RetY), Purity, EvalMethod),
+ HeadTypeParams, !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
+ type_unify(RetX, RetY, HeadTypeParams, !Bindings).
+type_unify_nonvar(tuple(ArgsX, _), tuple(ArgsY, _), HeadTypeParams,
+ !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+
+ % Handle apply_n types and kinded types.
+ %
+:- pred type_unify_special(mer_type::in, mer_type::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_special(X, Y, HeadTypeParams, !Bindings) :-
+ ( X = apply_n(VarX, ArgsX, _) ->
+ type_unify_apply(Y, VarX, ArgsX, HeadTypeParams, !Bindings)
+ ; Y = apply_n(VarY, ArgsY, _) ->
+ type_unify_apply(X, VarY, ArgsY, HeadTypeParams, !Bindings)
+ ; X = kinded(RawX, _) ->
+ ( Y = kinded(RawY, _) ->
+ type_unify(RawX, RawY, HeadTypeParams, !Bindings)
+ ;
+ type_unify(RawX, Y, HeadTypeParams, !Bindings)
+ )
+ ; Y = kinded(RawY, _) ->
+ type_unify(X, RawY, HeadTypeParams, !Bindings)
+ ;
+ fail
).
-apply_type_args_to_kind(variable(_), [_ | _], _) :-
- unexpected(this_file, "unbound kind variable").
-:- pred ensure_type_has_kind(kind::in, mer_type::in, mer_type::out) is det.
+ % The idea here is that we try to strip off arguments from Y starting
+ % from the end and unify each with the corresponding argument of X.
+ % If we reach an atomic type before the arguments run out then we fail.
+ % If we reach a variable before the arguments run out then we unify it
+ % with what remains of the apply_n expression. If we manage to unify
+ % all of the arguments then we unify the apply_n variable with what
+ % remains of the other expression.
+ %
+ % Note that Y is not a variable, since that case would have been
+ % caught by type_unify.
+ %
+:- pred type_unify_apply(mer_type::in, tvar::in, list(mer_type)::in,
+ list(tvar)::in, tsubst::in, tsubst::out) is semidet.
+
+type_unify_apply(defined(NameY, ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
+ !Bindings) :-
+ type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings),
+ type_unify_var(VarX, defined(NameY, ArgsY, KindY), HeadTypeParams,
+ !Bindings).
+type_unify_apply(Type @ builtin(_), VarX, [], HeadTypeParams, !Bindings) :-
+ type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
+type_unify_apply(Type @ higher_order(_, _, _, _), VarX, [], HeadTypeParams,
+ !Bindings) :-
+ type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
+type_unify_apply(tuple(ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
+ !Bindings) :-
+ type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings),
+ type_unify_var(VarX, tuple(ArgsY, KindY), HeadTypeParams, !Bindings).
+type_unify_apply(apply_n(VarY, ArgsY0, Kind0), VarX, ArgsX0, HeadTypeParams,
+ !Bindings) :-
+ list.length(ArgsX0, NArgsX0),
+ list.length(ArgsY0, NArgsY0),
+ compare(Result, NArgsX0, NArgsY0),
+ (
+ Result = (<),
+ type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarX, apply_n(VarY, ArgsY, Kind),
+ HeadTypeParams, !Bindings)
+ ;
+ Result = (=),
+ % We know here that the list of remaining args will be empty.
+ type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
+ !Bindings),
+ type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
+ ;
+ Result = (>),
+ type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarY, apply_n(VarX, ArgsX, Kind),
+ HeadTypeParams, !Bindings)
+ ).
+type_unify_apply(kinded(RawY, _), VarX, ArgsX, HeadTypeParams, !Bindings) :-
+ type_unify_apply(RawY, VarX, ArgsX, HeadTypeParams, !Bindings).
+
+:- pred type_unify_args(list(mer_type)::in, list(mer_type)::in,
+ list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings) :-
+ list.reverse(ArgsX, RevArgsX),
+ list.reverse(ArgsY0, RevArgsY0),
+ type_unify_rev_args(RevArgsX, RevArgsY0, RevArgsY, KindY0, KindY,
+ HeadTypeParams, !Bindings),
+ list.reverse(RevArgsY, ArgsY).
+
+:- pred type_unify_rev_args(list(mer_type)::in, list(mer_type)::in,
+ list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_rev_args([], ArgsY, ArgsY, KindY, KindY, _, !Bindings).
+type_unify_rev_args([ArgX | ArgsX], [ArgY0 | ArgsY0], ArgsY, KindY0, KindY,
+ HeadTypeParams, !Bindings) :-
+ type_unify(ArgX, ArgY0, HeadTypeParams, !Bindings),
+ KindY1 = arrow(get_type_kind(ArgY0), KindY0),
+ type_unify_rev_args(ArgsX, ArgsY0, ArgsY, KindY1, KindY,
+ HeadTypeParams, !Bindings).
+
+type_unify_list([], [], _HeadTypeParams, !Bindings).
+type_unify_list([X | Xs], [Y | Ys], HeadTypeParams, !Bindings) :-
+ type_unify(X, Y, HeadTypeParams, !Bindings),
+ type_unify_list(Xs, Ys, HeadTypeParams, !Bindings).
+
+ % type_occurs(Type, Var, Subst) succeeds iff Type contains Var,
+ % perhaps indirectly via the substitution. (The variable must not
+ % be mapped by the substitution.)
+ %
+:- pred type_occurs(mer_type::in, tvar::in, tsubst::in) is semidet.
-ensure_type_has_kind(Kind, Type0, Type) :-
- ( get_type_kind(Type0) = Kind ->
- Type = Type0
+type_occurs(variable(X, _), Y, Bindings) :-
+ ( X = Y ->
+ true
;
- unexpected(this_file, "substitution not kind preserving")
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ ).
+type_occurs(defined(_, Args, _), Y, Bindings) :-
+ type_occurs_list(Args, Y, Bindings).
+type_occurs(higher_order(Args, MaybeRet, _, _), Y, Bindings) :-
+ (
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ MaybeRet = yes(Ret),
+ type_occurs(Ret, Y, Bindings)
+ ).
+type_occurs(tuple(Args, _), Y, Bindings) :-
+ type_occurs_list(Args, Y, Bindings).
+type_occurs(apply_n(X, Args, _), Y, Bindings) :-
+ (
+ X = Y
+ ;
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ ).
+type_occurs(kinded(X, _), Y, Bindings) :-
+ type_occurs(X, Y, Bindings).
+
+:- pred type_occurs_list(list(mer_type)::in, tvar::in, tsubst::in) is semidet.
+
+type_occurs_list([X | Xs], Y, Bindings) :-
+ (
+ type_occurs(X, Y, Bindings)
+ ;
+ type_occurs_list(Xs, Y, Bindings)
).
%-----------------------------------------------------------------------------%
-apply_rec_subst_to_prog_constraints(Subst, Constraints0, Constraints) :-
- Constraints0 = constraints(UnivCs0, ExistCs0),
- apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs),
- apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs),
- Constraints = constraints(UnivCs, ExistCs).
-
-apply_rec_subst_to_prog_constraint_list(Subst, !Constraints) :-
- list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints).
-
-apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
- Constraint0 = constraint(ClassName, Types0),
- apply_rec_subst_to_type_list(Subst, Types0, Types),
- Constraint = constraint(ClassName, Types).
-
-apply_subst_to_prog_constraints(Subst,
- constraints(UniversalCs0, ExistentialCs0),
- constraints(UniversalCs, ExistentialCs)) :-
- apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs),
- apply_subst_to_prog_constraint_list(Subst, ExistentialCs0,
- ExistentialCs).
-
-apply_subst_to_prog_constraint_list(Subst, !Constraints) :-
- list__map(apply_subst_to_prog_constraint(Subst), !Constraints).
-
-apply_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
- Constraint0 = constraint(ClassName, Types0),
- apply_subst_to_type_list(Subst, Types0, Types),
- Constraint = constraint(ClassName, Types).
-
-apply_variable_renaming_to_prog_constraints(Renaming, Constraints0,
- Constraints) :-
- Constraints0 = constraints(UnivConstraints0, ExistConstraints0),
- apply_variable_renaming_to_prog_constraint_list(Renaming,
- UnivConstraints0, UnivConstraints),
- apply_variable_renaming_to_prog_constraint_list(Renaming,
- ExistConstraints0, ExistConstraints),
- Constraints = constraints(UnivConstraints, ExistConstraints).
-
-apply_variable_renaming_to_prog_constraint_list(Renaming, !Constraints) :-
- list.map(apply_variable_renaming_to_prog_constraint(Renaming),
- !Constraints).
-
-apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :-
- !.Constraint = constraint(ClassName, ClassArgTypes0),
- apply_variable_renaming_to_type_list(Renaming,
- ClassArgTypes0, ClassArgTypes),
- !:Constraint = constraint(ClassName, ClassArgTypes).
+type_list_subsumes(TypesA, TypesB, TypeSubst) :-
+ %
+ % TypesA subsumes TypesB iff TypesA can be unified with TypesB
+ % without binding any of the type variables in TypesB.
+ %
+ prog_type__vars_list(TypesB, TypesBVars),
+ map__init(TypeSubst0),
+ type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
+
+type_list_subsumes_det(TypesA, TypesB, TypeSubst) :-
+ ( type_list_subsumes(TypesA, TypesB, TypeSubstPrime) ->
+ TypeSubst = TypeSubstPrime
+ ;
+ error("type_list_subsumes_det: type_list_subsumes failed")
+ ).
+
+arg_type_list_subsumes(TVarSet, ActualArgTypes, CalleeTVarSet, PredKindMap,
+ PredExistQVars, PredArgTypes) :-
+ % Rename the type variables in the callee's argument types.
+ tvarset_merge_renaming(TVarSet, CalleeTVarSet, _TVarSet1, Renaming),
+ apply_variable_renaming_to_tvar_kind_map(Renaming, PredKindMap,
+ ParentKindMap),
+ apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
+ ParentArgTypes),
+ apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
+ ParentExistQVars),
+
+ % Check that the types of the candidate predicate/function
+ % subsume the actual argument types.
+ % [This is the right thing to do even for calls to
+ % existentially typed preds, because we're using the
+ % type variables from the callee's pred decl (obtained
+ % from the pred_info via pred_info_arg_types) not the types
+ % inferred from the callee's clauses (and stored in the
+ % clauses_info and proc_info) -- the latter
+ % might not subsume the actual argument types.]
-constraint_list_get_tvars(Constraints, TVars) :-
- list.map(constraint_get_tvars, Constraints, TVarsList),
- list.condense(TVarsList, TVars).
+ type_list_subsumes(ParentArgTypes, ActualArgTypes, ParentToActualSubst),
-constraint_get_tvars(constraint(_Name, Args), TVars) :-
- prog_type.vars_list(Args, TVars).
+ % Check that the type substitution did not bind any existentially
+ % typed variables to non-ground types.
+ (
+ ParentExistQVars = []
+ % Optimize common case.
+ ;
+ ParentExistQVars = [_ | _],
+ apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualSubst,
+ ParentExistQVars, ActualExistQTypes),
+ all [T] (list__member(T, ActualExistQTypes) => T = variable(_, _))
+
+ % It might make sense to also check that the type substitution
+ % did not bind any existentially typed variables to universally
+ % quantified type variables in the caller's argument types.
+ ).
-get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :-
- constraint_list_get_tvars(Constraints, ConstrainedTvars),
- list.delete_elems(Tvars, ConstrainedTvars, Unconstrained0),
- list.remove_dups(Unconstrained0, Unconstrained).
+%-----------------------------------------------------------------------------%
+
+
+apply_partial_map_to_list(_PartialMap, [], []).
+apply_partial_map_to_list(PartialMap, [X | Xs], [Y | Ys]) :-
+ ( map__search(PartialMap, X, Y0) ->
+ Y = Y0
+ ;
+ Y = X
+ ),
+ apply_partial_map_to_list(PartialMap, Xs, Ys).
%-----------------------------------------------------------------------------%
Index: compiler/prog_type_subst.m
===================================================================
RCS file: compiler/prog_type_subst.m
diff -N compiler/prog_type_subst.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/prog_type_subst.m 1 Nov 2005 04:02:08 -0000
@@ -0,0 +1,436 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% Operations for performing various kinds of type substitutions on data
+% structures that are part of the parse tree.
+%
+%-----------------------------------------------------------------------------%
+
+:- module parse_tree.prog_type_subst.
+
+:- interface.
+
+:- import_module parse_tree.prog_data.
+
+:- import_module list.
+
+%-----------------------------------------------------------------------------%
+%
+% Type substitutions.
+%
+
+:- pred apply_variable_renaming_to_tvar_kind_map(tvar_renaming::in,
+ tvar_kind_map::in, tvar_kind_map::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_tvar(tvar_renaming::in,
+ tvar::in, tvar::out) is det.
+
+:- pred apply_subst_to_tvar(tvar_kind_map::in, tsubst::in,
+ tvar::in, mer_type::out) is det.
+
+:- pred apply_rec_subst_to_tvar(tvar_kind_map::in, tsubst::in,
+ tvar::in, mer_type::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_tvar_list(tvar_renaming::in,
+ list(tvar)::in, list(tvar)::out) is det.
+
+:- pred apply_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
+ list(tvar)::in, list(mer_type)::out) is det.
+
+:- pred apply_rec_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
+ list(tvar)::in, list(mer_type)::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_type(tvar_renaming::in,
+ mer_type::in, mer_type::out) is det.
+
+:- pred apply_subst_to_type(tsubst::in, mer_type::in, mer_type::out) is det.
+
+:- pred apply_rec_subst_to_type(tsubst::in, mer_type::in, mer_type::out)
+ is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_type_list(tvar_renaming::in,
+ list(mer_type)::in, list(mer_type)::out) is det.
+
+:- pred apply_subst_to_type_list(tsubst::in,
+ list(mer_type)::in, list(mer_type)::out) is det.
+
+:- pred apply_rec_subst_to_type_list(tsubst::in,
+ list(mer_type)::in, list(mer_type)::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_vartypes(tvar_renaming::in,
+ vartypes::in, vartypes::out) is det.
+
+:- pred apply_subst_to_vartypes(tsubst::in, vartypes::in, vartypes::out)
+ is det.
+
+:- pred apply_rec_subst_to_vartypes(tsubst::in, vartypes::in, vartypes::out)
+ is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Utility predicates dealing with typeclass constraints.
+%
+
+:- pred apply_variable_renaming_to_prog_constraint(tvar_renaming::in,
+ prog_constraint::in, prog_constraint::out) is det.
+
+:- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
+ prog_constraint::out) is det.
+
+:- pred apply_rec_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
+ prog_constraint::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_prog_constraint_list(tvar_renaming::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+:- pred apply_subst_to_prog_constraint_list(tsubst::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+:- pred apply_rec_subst_to_prog_constraint_list(tsubst::in,
+ list(prog_constraint)::in, list(prog_constraint)::out) is det.
+
+%---------%
+
+:- pred apply_variable_renaming_to_prog_constraints(tvar_renaming::in,
+ prog_constraints::in, prog_constraints::out) is det.
+
+:- pred apply_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
+ prog_constraints::out) is det.
+
+:- pred apply_rec_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
+ prog_constraints::out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module libs.compiler_util.
+:- import_module parse_tree.prog_io.
+:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_util.
+
+:- import_module map.
+:- import_module std_util.
+:- import_module svmap.
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap) :-
+ map__foldl(apply_variable_renaming_to_tvar_kind_map_2(Renaming),
+ KindMap0, map__init, KindMap).
+
+:- pred apply_variable_renaming_to_tvar_kind_map_2(tvar_renaming::in, tvar::in,
+ kind::in, tvar_kind_map::in, tvar_kind_map::out) is det.
+
+apply_variable_renaming_to_tvar_kind_map_2(Renaming, TVar0, Kind, !KindMap) :-
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar),
+ svmap__det_insert(TVar, Kind, !KindMap).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_tvar(Renaming, TVar0, TVar) :-
+ ( map__search(Renaming, TVar0, TVar1) ->
+ TVar = TVar1
+ ;
+ TVar = TVar0
+ ).
+
+apply_subst_to_tvar(KindMap, Subst, TVar, Type) :-
+ ( map__search(Subst, TVar, Type0) ->
+ apply_subst_to_type(Subst, Type0, Type)
+ ;
+ get_tvar_kind(KindMap, TVar, Kind),
+ Type = variable(TVar, Kind)
+ ).
+
+
+apply_rec_subst_to_tvar(KindMap, Subst, TVar, Type) :-
+ ( map__search(Subst, TVar, Type0) ->
+ apply_rec_subst_to_type(Subst, Type0, Type)
+ ;
+ get_tvar_kind(KindMap, TVar, Kind),
+ Type = variable(TVar, Kind)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_tvar_list(Renaming, TVars0, TVars) :-
+ list__map(apply_variable_renaming_to_tvar(Renaming), TVars0, TVars).
+
+apply_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
+ list__map(apply_subst_to_tvar(KindMap, Subst), TVars, Types).
+
+apply_rec_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
+ list__map(apply_rec_subst_to_tvar(KindMap, Subst), TVars, Types).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_type(Renaming, variable(TVar0, Kind),
+ variable(TVar, Kind)) :-
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
+apply_variable_renaming_to_type(Renaming, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args).
+apply_variable_renaming_to_type(_Renaming, Type @ builtin(_), Type).
+apply_variable_renaming_to_type(Renaming,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_variable_renaming_to_type(Renaming, Return0, Return),
+ MaybeReturn = yes(Return)
+ ;
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_variable_renaming_to_type(Renaming, tuple(Args0, Kind),
+ tuple(Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args).
+apply_variable_renaming_to_type(Renaming, apply_n(TVar0, Args0, Kind),
+ apply_n(TVar, Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args),
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
+apply_variable_renaming_to_type(Renaming, kinded(Type0, Kind),
+ kinded(Type, Kind)) :-
+ apply_variable_renaming_to_type(Renaming, Type0, Type).
+
+apply_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
+ ( map__search(Subst, TVar, Type1) ->
+ ensure_type_has_kind(Kind, Type1, Type)
+ ;
+ Type = Type0
+ ).
+apply_subst_to_type(Subst, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_subst_to_type_list(Subst, Args0, Args).
+apply_subst_to_type(_Subst, Type @ builtin(_), Type).
+apply_subst_to_type(Subst,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_subst_to_type_list(Subst, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_subst_to_type(Subst, Return0, Return),
+ MaybeReturn = yes(Return)
+ ;
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
+ apply_subst_to_type_list(Subst, Args0, Args).
+apply_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
+ apply_subst_to_type_list(Subst, Args0, Args),
+ ( map__search(Subst, TVar, AppliedType) ->
+ apply_type_args(AppliedType, Args, Type)
+ ;
+ Type = apply_n(TVar, Args, Kind)
+ ).
+apply_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
+ apply_subst_to_type(Subst, Type0, Type).
+
+apply_rec_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
+ ( map__search(Subst, TVar, Type1) ->
+ ensure_type_has_kind(Kind, Type1, Type2),
+ apply_rec_subst_to_type(Subst, Type2, Type)
+ ;
+ Type = Type0
+ ).
+apply_rec_subst_to_type(Subst, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args).
+apply_rec_subst_to_type(_Subst, Type @ builtin(_), Type).
+apply_rec_subst_to_type(Subst,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_rec_subst_to_type(Subst, Return0, Return),
+ MaybeReturn = yes(Return)
+ ;
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_rec_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args).
+apply_rec_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args),
+ ( map__search(Subst, TVar, AppliedType0) ->
+ apply_rec_subst_to_type(Subst, AppliedType0, AppliedType),
+ apply_type_args(AppliedType, Args, Type)
+ ;
+ Type = apply_n(TVar, Args, Kind)
+ ).
+apply_rec_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
+ apply_rec_subst_to_type(Subst, Type0, Type).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_type_list(Renaming, Types0, Types) :-
+ list__map(apply_variable_renaming_to_type(Renaming), Types0, Types).
+
+apply_subst_to_type_list(Subst, Types0, Types) :-
+ list__map(apply_subst_to_type(Subst), Types0, Types).
+
+apply_rec_subst_to_type_list(Subst, Types0, Types) :-
+ list__map(apply_rec_subst_to_type(Subst), Types0, Types).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_vartypes(Renaming, !Map) :-
+ map__map_values(apply_variable_renaming_to_vartypes_2(Renaming), !Map).
+
+:- pred apply_variable_renaming_to_vartypes_2(tvar_renaming::in, prog_var::in,
+ mer_type::in, mer_type::out) is det.
+
+apply_variable_renaming_to_vartypes_2(Renaming, _, !Type) :-
+ apply_variable_renaming_to_type(Renaming, !Type).
+
+apply_subst_to_vartypes(Subst, !VarTypes) :-
+ map__map_values(apply_subst_to_vartypes_2(Subst), !VarTypes).
+
+:- pred apply_subst_to_vartypes_2(tsubst::in, prog_var::in,
+ mer_type::in, mer_type::out) is det.
+
+apply_subst_to_vartypes_2(Subst, _, !Type) :-
+ apply_subst_to_type(Subst, !Type).
+
+apply_rec_subst_to_vartypes(Subst, !VarTypes) :-
+ map__map_values(apply_rec_subst_to_vartypes_2(Subst), !VarTypes).
+
+:- pred apply_rec_subst_to_vartypes_2(tsubst::in, prog_var::in,
+ mer_type::in, mer_type::out) is det.
+
+apply_rec_subst_to_vartypes_2(Subst, _, !Type) :-
+ apply_rec_subst_to_type(Subst, !Type).
+
+%-----------------------------------------------------------------------------%
+
+:- pred apply_type_args(mer_type::in, list(mer_type)::in, mer_type::out)
+ is det.
+
+apply_type_args(variable(TVar, Kind0), Args, apply_n(TVar, Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(defined(Name, Args0, Kind0), Args,
+ defined(Name, Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(Type @ builtin(_), [], Type).
+apply_type_args(builtin(_), [_ | _], _) :-
+ unexpected(this_file, "applied type args to builtin").
+apply_type_args(Type @ higher_order(_, _, _, _), [], Type).
+apply_type_args(higher_order(_, _, _, _), [_ | _], _) :-
+ unexpected(this_file, "applied type args to higher_order").
+apply_type_args(tuple(Args0, Kind0), Args, tuple(Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(apply_n(TVar, Args0, Kind0), Args,
+ apply_n(TVar, Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(kinded(Type0, _), Args, Type) :-
+ % We drop the explicit kind annotation, since:
+ % - it will already have been used by kind inference, and
+ % - it no longer corresponds to any explicit annotation given.
+ apply_type_args(Type0, Args, Type).
+
+:- pred apply_type_args_to_kind(kind::in, list(mer_type)::in, kind::out)
+ is det.
+
+apply_type_args_to_kind(Kind, [], Kind).
+apply_type_args_to_kind(star, [_ | _], _) :-
+ unexpected(this_file, "too many args in apply_n").
+apply_type_args_to_kind(arrow(Kind0, Kind1), [ArgType | ArgTypes], Kind) :-
+ ( get_type_kind(ArgType) = Kind0 ->
+ apply_type_args_to_kind(Kind1, ArgTypes, Kind)
+ ;
+ unexpected(this_file, "kind error in apply_n")
+ ).
+apply_type_args_to_kind(variable(_), [_ | _], _) :-
+ unexpected(this_file, "unbound kind variable").
+
+:- pred ensure_type_has_kind(kind::in, mer_type::in, mer_type::out) is det.
+
+ensure_type_has_kind(Kind, Type0, Type) :-
+ ( get_type_kind(Type0) = Kind ->
+ Type = Type0
+ ;
+ unexpected(this_file, "substitution not kind preserving")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :-
+ !.Constraint = constraint(ClassName, ClassArgTypes0),
+ apply_variable_renaming_to_type_list(Renaming,
+ ClassArgTypes0, ClassArgTypes),
+ !:Constraint = constraint(ClassName, ClassArgTypes).
+
+apply_subst_to_prog_constraint(Subst, !Constraint) :-
+ !.Constraint = constraint(ClassName, Types0),
+ apply_subst_to_type_list(Subst, Types0, Types),
+ !:Constraint = constraint(ClassName, Types).
+
+apply_rec_subst_to_prog_constraint(Subst, !Constraint) :-
+ !.Constraint = constraint(ClassName, Types0),
+ apply_rec_subst_to_type_list(Subst, Types0, Types),
+ !:Constraint = constraint(ClassName, Types).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_prog_constraint_list(Renaming, !Constraints) :-
+ list.map(apply_variable_renaming_to_prog_constraint(Renaming),
+ !Constraints).
+
+apply_subst_to_prog_constraint_list(Subst, !Constraints) :-
+ list__map(apply_subst_to_prog_constraint(Subst), !Constraints).
+
+apply_rec_subst_to_prog_constraint_list(Subst, !Constraints) :-
+ list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints).
+
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_prog_constraints(Renaming, !Constraints) :-
+ !.Constraints = constraints(UnivConstraints0, ExistConstraints0),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ UnivConstraints0, UnivConstraints),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ ExistConstraints0, ExistConstraints),
+ !:Constraints = constraints(UnivConstraints, ExistConstraints).
+
+apply_subst_to_prog_constraints(Subst,
+ constraints(UniversalCs0, ExistentialCs0),
+ constraints(UniversalCs, ExistentialCs)) :-
+ apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs),
+ apply_subst_to_prog_constraint_list(Subst, ExistentialCs0,
+ ExistentialCs).
+
+apply_rec_subst_to_prog_constraints(Subst, !Constraints) :-
+ !.Constraints = constraints(UnivCs0, ExistCs0),
+ apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs),
+ apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs),
+ !:Constraints = constraints(UnivCs, ExistCs).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prog_type_subst.m".
+
+%-----------------------------------------------------------------------------%
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.81
diff -u -b -r1.81 purity.m
--- compiler/purity.m 28 Oct 2005 02:10:31 -0000 1.81
+++ compiler/purity.m 1 Nov 2005 09:18:09 -0000
@@ -147,14 +147,6 @@
:- pred repuritycheck_proc(module_info::in, pred_proc_id::in, pred_info::in,
pred_info::out) is det.
- % Sort of a "maximum" for impurity.
- %
-:- func worst_purity(purity, purity) = purity.
-
- % Compare two purities.
- %
-:- pred less_pure(purity::in, purity::in) is semidet.
-
% Give an error message for unifications marked impure/semipure
% that are not function calls (e.g. impure X = 4)
%
@@ -212,39 +204,6 @@
maybe_write_string(Verbose, "% Purity-checking clauses...\n", !IO),
check_preds_purity(FoundTypeError, PostTypecheckError, !HLDS, !IO),
maybe_report_stats(Statistics, !IO).
-
-less_pure(P1, P2) :-
- \+ ( worst_purity(P1, P2) = P2).
-
-% worst_purity/3 could be written more compactly, but this definition
-% guarantees us a determinism error if we add to type `purity'. We also
-% define less_pure/2 in terms of worst_purity/3 rather than the other way
-% around for the same reason.
-
-worst_purity(purity_pure, purity_pure) = purity_pure.
-worst_purity(purity_pure, purity_semipure) = purity_semipure.
-worst_purity(purity_pure, purity_impure) = purity_impure.
-worst_purity(purity_semipure, purity_pure) = purity_semipure.
-worst_purity(purity_semipure, purity_semipure) = purity_semipure.
-worst_purity(purity_semipure, purity_impure) = purity_impure.
-worst_purity(purity_impure, purity_pure) = purity_impure.
-worst_purity(purity_impure, purity_semipure) = purity_impure.
-worst_purity(purity_impure, purity_impure) = purity_impure.
-
- % Sort of a "minimum" for impurity. The reason why this is written is
- % as a switch is the same as for worst_purity.
- %
-:- func best_purity(purity, purity) = purity.
-
-best_purity(purity_pure, purity_pure) = purity_pure.
-best_purity(purity_pure, purity_semipure) = purity_pure.
-best_purity(purity_pure, purity_impure) = purity_pure.
-best_purity(purity_semipure, purity_pure) = purity_pure.
-best_purity(purity_semipure, purity_semipure) = purity_semipure.
-best_purity(purity_semipure, purity_impure) = purity_semipure.
-best_purity(purity_impure, purity_pure) = purity_pure.
-best_purity(purity_impure, purity_semipure) = purity_semipure.
-best_purity(purity_impure, purity_impure) = purity_impure.
%-----------------------------------------------------------------------------%
Index: compiler/qual_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/qual_info.m,v
retrieving revision 1.5
diff -u -b -r1.5 qual_info.m
--- compiler/qual_info.m 28 Oct 2005 02:10:31 -0000 1.5
+++ compiler/qual_info.m 1 Nov 2005 05:56:03 -0000
@@ -85,6 +85,7 @@
:- import_module hlds.hlds_data.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module map.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.29
diff -u -b -r1.29 recompilation.version.m
--- compiler/recompilation.version.m 28 Oct 2005 02:10:32 -0000 1.29
+++ compiler/recompilation.version.m 1 Nov 2005 05:29:08 -0000
@@ -51,6 +51,7 @@
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
Index: compiler/rl.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rl.m,v
retrieving revision 1.38
diff -u -b -r1.38 rl.m
--- compiler/rl.m 28 Oct 2005 02:10:32 -0000 1.38
+++ compiler/rl.m 1 Nov 2005 05:08:03 -0000
@@ -1141,7 +1141,7 @@
module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, ProcInfo),
pred_info_arg_types(PredInfo, ArgTypes0),
proc_info_argmodes(ProcInfo, ArgModes0),
- type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes),
+ remove_aditi_state(ArgTypes0, ArgModes0, ArgModes),
partition_args(ModuleInfo, ArgModes, ArgModes, _, OutputArgModes),
% The interface procedure includes only the output arguments
@@ -1168,7 +1168,7 @@
PredArity = pred_info_orig_arity(PredInfo),
string__format("%s__%i", [s(PredName), i(PredArity)], RelName),
pred_info_arg_types(PredInfo, ArgTypes0),
- type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
+ remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
rl__schema_to_string(ModuleInfo, ArgTypes, SchemaString).
%-----------------------------------------------------------------------------%
@@ -1261,75 +1261,75 @@
rl__gather_type(ModuleInfo, Parents, Type, GatheredTypes0, GatheredTypes,
RecursiveTypes0, RecursiveTypes, Decls0, Decls, ThisType) :-
ClassifiedType0 = classify_type(ModuleInfo, Type),
- ( ClassifiedType0 = enum_type ->
- ClassifiedType = user_ctor_type
- ; ClassifiedType0 = dummy_type ->
+ ( ClassifiedType0 = type_cat_enum ->
+ ClassifiedType = type_cat_user_ctor
+ ; ClassifiedType0 = type_cat_dummy ->
% XXX The correctness of this is extremely suspect, but a
% correct solution would probably require changes to to Aditi.
- ClassifiedType = user_ctor_type
+ ClassifiedType = type_cat_user_ctor
;
ClassifiedType = ClassifiedType0
),
(
- ClassifiedType = enum_type,
+ ClassifiedType = type_cat_enum,
% this is converted to user_type above
error("rl__gather_type: enum type")
;
- ClassifiedType = dummy_type,
+ ClassifiedType = type_cat_dummy,
% this is converted to user_type above
error("rl__gather_type: dummy type")
;
- ClassifiedType = variable_type,
+ ClassifiedType = type_cat_variable,
error("rl__gather_type: variable type")
;
- ClassifiedType = char_type,
+ ClassifiedType = type_cat_char,
GatheredTypes = GatheredTypes0,
RecursiveTypes = RecursiveTypes0,
Decls = Decls0,
ThisType = ":I"
;
- ClassifiedType = int_type,
+ ClassifiedType = type_cat_int,
GatheredTypes = GatheredTypes0,
RecursiveTypes = RecursiveTypes0,
Decls = Decls0,
ThisType = ":I"
;
- ClassifiedType = float_type,
+ ClassifiedType = type_cat_float,
GatheredTypes = GatheredTypes0,
RecursiveTypes = RecursiveTypes0,
Decls = Decls0,
ThisType = ":D"
;
- ClassifiedType = str_type,
+ ClassifiedType = type_cat_string,
GatheredTypes = GatheredTypes0,
RecursiveTypes = RecursiveTypes0,
Decls = Decls0,
ThisType = ":S"
;
- ClassifiedType = tuple_type,
+ ClassifiedType = type_cat_tuple,
rl__gather_du_type(ModuleInfo, Parents, Type, GatheredTypes0,
GatheredTypes, RecursiveTypes0, RecursiveTypes,
Decls0, Decls, ThisType)
;
- ClassifiedType = void_type,
+ ClassifiedType = type_cat_void,
error("rl__gather_type: void type")
;
- ClassifiedType = type_info_type,
+ ClassifiedType = type_cat_type_info,
error("rl__gather_type: type_info type")
;
- ClassifiedType = type_ctor_info_type,
+ ClassifiedType = type_cat_type_ctor_info,
error("rl__gather_type: type_ctor_info type")
;
- ClassifiedType = typeclass_info_type,
+ ClassifiedType = type_cat_typeclass_info,
error("rl__gather_type: typeclass_info type")
;
- ClassifiedType = base_typeclass_info_type,
+ ClassifiedType = type_cat_base_typeclass_info,
error("rl__gather_type: base_typeclass_info type")
;
- ClassifiedType = higher_order_type,
+ ClassifiedType = type_cat_higher_order,
error("rl__gather_type: higher_order type")
;
- ClassifiedType = user_ctor_type,
+ ClassifiedType = type_cat_user_ctor,
% We can't handle abstract types here. magic_util.m
% checks that there are none.
rl__gather_du_type(ModuleInfo, Parents, Type, GatheredTypes0,
Index: compiler/rl_key.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.26
diff -u -b -r1.26 rl_key.m
--- compiler/rl_key.m 28 Oct 2005 02:10:33 -0000 1.26
+++ compiler/rl_key.m 1 Nov 2005 05:01:24 -0000
@@ -20,7 +20,6 @@
:- import_module aditi_backend.rl.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
:- import_module parse_tree.prog_data.
:- import_module list.
@@ -58,6 +57,7 @@
:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_pred.
:- import_module hlds.special_pred.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_util.
@@ -140,8 +140,8 @@
ArgBound \= var - _
),
TypeCategory = classify_type(ModuleInfo, Type),
- ( TypeCategory = user_ctor_type
- ; TypeCategory = enum_type
+ ( TypeCategory = type_cat_user_ctor
+ ; TypeCategory = type_cat_enum
),
module_info_get_type_table(ModuleInfo, Types),
type_to_ctor_and_args(Type, TypeCtor, _),
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.62
diff -u -b -r1.62 rtti.m
--- compiler/rtti.m 28 Oct 2005 02:10:35 -0000 1.62
+++ compiler/rtti.m 1 Nov 2005 05:01:44 -0000
@@ -822,6 +822,7 @@
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util. % for mercury_public_builtin_module
:- import_module int.
@@ -1490,14 +1491,14 @@
;
TypeCtorDetails = foreign(IsStable),
(
- type_ctor_is_array(
- qualified(TypeCtorData ^ tcr_module_name,
- TypeCtorData ^ tcr_type_name) -
- TypeCtorData ^ tcr_arity)
+ ModuleName = TypeCtorData ^ tcr_module_name,
+ TypeName = TypeCtorData ^ tcr_type_name,
+ TypeArity = TypeCtorData ^ tcr_arity,
+ type_ctor_is_array(qualified(ModuleName, TypeName) - TypeArity)
->
- % XXX This is a kludge to allow accurate GC
- % to trace arrays. We should allow users to
- % provide tracing functions for foreign types.
+ % XXX This is a kludge to allow accurate GC to trace arrays.
+ % We should allow users to provide tracing functions for
+ % foreign types.
RepStr = "MR_TYPECTOR_REP_ARRAY"
;
(
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.64
diff -u -b -r1.64 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 28 Oct 2005 02:10:35 -0000 1.64
+++ compiler/rtti_to_mlds.m 1 Nov 2005 05:58:46 -0000
@@ -65,6 +65,7 @@
:- import_module ml_backend.ml_unify_gen.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -863,7 +864,7 @@
gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames) = MLDS_Defn :-
StrType = builtin(string),
Init = gen_init_array(gen_init_maybe(
- mercury_type(StrType, str_type, non_foreign_type(StrType)),
+ mercury_type(StrType, type_cat_string, non_foreign_type(StrType)),
gen_init_string), MaybeNames),
RttiName = field_names(Ordinal),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Init, MLDS_Defn).
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.159
diff -u -b -r1.159 simplify.m
--- compiler/simplify.m 28 Oct 2005 02:10:35 -0000 1.159
+++ compiler/simplify.m 1 Nov 2005 04:45:38 -0000
@@ -109,6 +109,7 @@
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.const_prop.
:- import_module transform_hlds.pd_cost.
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.56
diff -u -b -r1.56 special_pred.m
--- compiler/special_pred.m 28 Oct 2005 02:10:36 -0000 1.56
+++ compiler/special_pred.m 1 Nov 2005 04:57:07 -0000
@@ -112,6 +112,7 @@
:- import_module libs.options.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module bool.
@@ -183,10 +184,10 @@
special_pred_is_generated_lazily(ModuleInfo, TypeCtor) :-
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = tuple_type
+ TypeCategory = type_cat_tuple
;
- ( TypeCategory = user_ctor_type
- ; TypeCategory = enum_type
+ ( TypeCategory = type_cat_user_ctor
+ ; TypeCategory = type_cat_enum
; is_introduced_type_info_type_category(TypeCategory) = yes
),
module_info_get_type_table(ModuleInfo, Types),
@@ -207,10 +208,10 @@
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
(
- TypeCategory = tuple_type
+ TypeCategory = type_cat_tuple
;
- ( TypeCategory = user_ctor_type
- ; TypeCategory = enum_type
+ ( TypeCategory = type_cat_user_ctor
+ ; TypeCategory = type_cat_enum
; is_introduced_type_info_type_category(TypeCategory) = yes
),
special_pred_is_generated_lazily_2(ModuleInfo, TypeCtor, Body, Status)
Index: compiler/string_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/string_switch.m,v
retrieving revision 1.50
diff -u -b -r1.50 string_switch.m
--- compiler/string_switch.m 28 Oct 2005 02:10:37 -0000 1.50
+++ compiler/string_switch.m 1 Nov 2005 10:20:11 -0000
@@ -21,7 +21,6 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module ll_backend.code_info.
:- import_module ll_backend.llds.
@@ -37,6 +36,7 @@
:- implementation.
:- import_module backend_libs.builtin_ops.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
:- import_module libs.tree.
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.90
diff -u -b -r1.90 switch_gen.m
--- compiler/switch_gen.m 28 Oct 2005 02:10:37 -0000 1.90
+++ compiler/switch_gen.m 1 Nov 2005 10:20:28 -0000
@@ -48,7 +48,6 @@
:- interface.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module ll_backend.code_info.
:- import_module ll_backend.llds.
@@ -67,6 +66,7 @@
:- import_module backend_libs.switch_util.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_form.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module libs.globals.
:- import_module libs.options.
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.26
diff -u -b -r1.26 switch_util.m
--- compiler/switch_util.m 28 Oct 2005 02:10:37 -0000 1.26
+++ compiler/switch_util.m 1 Nov 2005 05:01:48 -0000
@@ -17,11 +17,11 @@
:- module backend_libs__switch_util.
:- interface.
-:- import_module check_hlds.type_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
:- import_module assoc_list.
:- import_module list.
@@ -245,27 +245,27 @@
% Stuff for categorizing switches
%
-type_cat_to_switch_cat(enum_type) = atomic_switch.
-type_cat_to_switch_cat(dummy_type) = _ :-
+type_cat_to_switch_cat(type_cat_enum) = atomic_switch.
+type_cat_to_switch_cat(type_cat_dummy) = _ :-
% You can't have a switch without at least two arms.
unexpected(this_file, "type_cat_to_switch_cat: dummy").
-type_cat_to_switch_cat(int_type) = atomic_switch.
-type_cat_to_switch_cat(char_type) = atomic_switch.
-type_cat_to_switch_cat(float_type) = other_switch.
-type_cat_to_switch_cat(str_type) = string_switch.
-type_cat_to_switch_cat(higher_order_type) = other_switch.
-type_cat_to_switch_cat(user_ctor_type) = tag_switch.
-type_cat_to_switch_cat(variable_type) = other_switch.
-type_cat_to_switch_cat(tuple_type) = other_switch.
-type_cat_to_switch_cat(void_type) = _ :-
+type_cat_to_switch_cat(type_cat_int) = atomic_switch.
+type_cat_to_switch_cat(type_cat_char) = atomic_switch.
+type_cat_to_switch_cat(type_cat_float) = other_switch.
+type_cat_to_switch_cat(type_cat_string) = string_switch.
+type_cat_to_switch_cat(type_cat_higher_order) = other_switch.
+type_cat_to_switch_cat(type_cat_user_ctor) = tag_switch.
+type_cat_to_switch_cat(type_cat_variable) = other_switch.
+type_cat_to_switch_cat(type_cat_tuple) = other_switch.
+type_cat_to_switch_cat(type_cat_void) = _ :-
unexpected(this_file, "type_cat_to_switch_cat: void").
-type_cat_to_switch_cat(type_info_type) = _ :-
+type_cat_to_switch_cat(type_cat_type_info) = _ :-
unexpected(this_file, "type_cat_to_switch_cat: type_info").
-type_cat_to_switch_cat(type_ctor_info_type) = _ :-
+type_cat_to_switch_cat(type_cat_type_ctor_info) = _ :-
unexpected(this_file, "type_cat_to_switch_cat: type_ctor_info").
-type_cat_to_switch_cat(typeclass_info_type) = _ :-
+type_cat_to_switch_cat(type_cat_typeclass_info) = _ :-
unexpected(this_file, "type_cat_to_switch_cat: typeclass_info").
-type_cat_to_switch_cat(base_typeclass_info_type) = _ :-
+type_cat_to_switch_cat(type_cat_base_typeclass_info) = _ :-
unexpected(this_file, "type_cat_to_switch_cat: base_typeclass_info").
switch_priority(no_tag) = 0. % should never occur
@@ -287,7 +287,7 @@
switch_priority(deep_profiling_proc_layout_tag(_, _)) = 6.
switch_priority(table_io_decl_tag(_, _)) = 6.
-type_range(char_type, _, _, MinChar, MaxChar) :-
+type_range(type_cat_char, _, _, MinChar, MaxChar) :-
% XXX the following code uses the host's character size,
% not the target's, so it won't work if cross-compiling
% to a machine with a different character size.
@@ -295,7 +295,7 @@
% in lookup_switch.m assume that char__min_char_value is 0.
char__min_char_value(MinChar),
char__max_char_value(MaxChar).
-type_range(enum_type, Type, ModuleInfo, 0, MaxEnum) :-
+type_range(type_cat_enum, Type, ModuleInfo, 0, MaxEnum) :-
( type_to_ctor_and_args(Type, TypeCtorPrime, _) ->
TypeCtor = TypeCtorPrime
;
@@ -312,9 +312,6 @@
).
%-----------------------------------------------------------------------------%
-
- % Find out how many secondary tags share each primary tag
- % of the given variable.
get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :-
( type_to_ctor_and_args(Type, TypeCtorPrime, _) ->
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.96
diff -u -b -r1.96 table_gen.m
--- compiler/table_gen.m 28 Oct 2005 02:10:37 -0000 1.96
+++ compiler/table_gen.m 1 Nov 2005 06:04:50 -0000
@@ -2229,7 +2229,7 @@
BindNextTableVar = ground_vars([NextTableVar]),
ArgName = arg_name(VarSeqNum),
ForeignArg = foreign_arg(ArgVar, yes(ArgName - in_mode), Type),
- ( TypeCat = enum_type ->
+ ( TypeCat = type_cat_enum ->
( type_to_ctor_and_args(Type, TypeCtor, _) ->
module_info_get_type_table(ModuleInfo, TypeDefnTable),
map__lookup(TypeDefnTable, TypeCtor, TypeDefn),
@@ -2262,7 +2262,7 @@
unexpected(this_file,
"gen_lookup_call_for_type: unexpected enum type")
)
- ; TypeCat = dummy_type ->
+ ; TypeCat = type_cat_dummy ->
generate_call("unify", det, [TableVar, NextTableVar],
impure_code, BindNextTableVar, ModuleInfo, Context, SetEqualGoal),
Goals = [SetEqualGoal],
@@ -2657,7 +2657,7 @@
ModuleInfo = !.TableInfo ^ table_module_info,
Name = arg_name(Offset),
ForeignArg = foreign_arg(Var, yes(Name - in_mode), Type),
- ( type_util__type_is_io_state(Type) ->
+ ( type_is_io_state(Type) ->
SavePredName = "table_save_io_state_answer",
generate_call(SavePredName, det, [TableVar, OffsetVar, Var],
impure_code, [], ModuleInfo, Context, Goal),
@@ -2917,7 +2917,7 @@
Offset, OffsetVar, ModuleInfo, Context, Goal, Var - Inst, Arg,
CodeStr) :-
Name = "restore_arg" ++ int_to_string(Offset),
- ( type_util__type_is_io_state(Type) ->
+ ( type_is_io_state(Type) ->
RestorePredName = "table_restore_io_state_answer",
ArgType = Type
; builtin_type(TypeCat) = no ->
@@ -3336,86 +3336,91 @@
%-----------------------------------------------------------------------------%
-% For backward compatibility, we treat type_info_type as user_type. This
-% used to make the tabling of type_infos more expensive than necessary, since
-% we essentially tabled the information in the type_info twice, once by tabling
-% the type represented by the type_info (since this was the value of the type
-% argument of the type constructor private_builtin.type_info/1), and then
-% tabling the type_info itself. However, since we made type_info have arity
-% zero, this overhead should be gone.
-
+ % For backward compatibility, we treat type_info_type as user_type.
+ % This used to make the tabling of type_infos more expensive than
+ % necessary, since we essentially tabled the information in the type_info
+ % twice, once by tabling the type represented by the type_info (since this
+ % was the value of the type argument of the type constructor
+ % private_builtin.type_info/1), and then tabling the type_info itself.
+ % However, since we made type_info have arity zero, this overhead
+ % should be gone.
+ %
:- func builtin_type(type_category) = bool.
-builtin_type(int_type) = yes.
-builtin_type(char_type) = yes.
-builtin_type(str_type) = yes.
-builtin_type(float_type) = yes.
-builtin_type(void_type) = yes.
-builtin_type(type_info_type) = no.
-builtin_type(type_ctor_info_type) = yes.
-builtin_type(typeclass_info_type) = yes.
-builtin_type(base_typeclass_info_type) = yes.
-builtin_type(higher_order_type) = no.
-builtin_type(enum_type) = no.
-builtin_type(dummy_type) = no.
-builtin_type(variable_type) = no.
-builtin_type(tuple_type) = no.
-builtin_type(user_ctor_type) = no.
-
-% Figure out what kind of data structure implements the lookup table for values
-% of a given builtin type.
+builtin_type(type_cat_int) = yes.
+builtin_type(type_cat_char) = yes.
+builtin_type(type_cat_string) = yes.
+builtin_type(type_cat_float) = yes.
+builtin_type(type_cat_void) = yes.
+builtin_type(type_cat_type_info) = no.
+builtin_type(type_cat_type_ctor_info) = yes.
+builtin_type(type_cat_typeclass_info) = yes.
+builtin_type(type_cat_base_typeclass_info) = yes.
+builtin_type(type_cat_higher_order) = no.
+builtin_type(type_cat_enum) = no.
+builtin_type(type_cat_dummy) = no.
+builtin_type(type_cat_variable) = no.
+builtin_type(type_cat_tuple) = no.
+builtin_type(type_cat_user_ctor) = no.
+ % Figure out what kind of data structure implements the lookup table
+ % for values of a given builtin type.
+ %
:- pred lookup_tabling_category(type_category::in,
maybe(pair(string, table_trie_step))::out) is det.
-lookup_tabling_category(int_type, yes("int" - table_trie_step_int)).
-lookup_tabling_category(char_type, yes("char" - table_trie_step_char)).
-lookup_tabling_category(str_type, yes("string" - table_trie_step_string)).
-lookup_tabling_category(float_type, yes("float" - table_trie_step_float)).
-lookup_tabling_category(void_type, _) :-
+lookup_tabling_category(type_cat_int,
+ yes("int" - table_trie_step_int)).
+lookup_tabling_category(type_cat_char,
+ yes("char" - table_trie_step_char)).
+lookup_tabling_category(type_cat_string,
+ yes("string" - table_trie_step_string)).
+lookup_tabling_category(type_cat_float,
+ yes("float" - table_trie_step_float)).
+lookup_tabling_category(type_cat_void, _) :-
unexpected(this_file, "lookup_tabling_category: void").
-lookup_tabling_category(dummy_type, _) :-
+lookup_tabling_category(type_cat_dummy, _) :-
unexpected(this_file, "lookup_tabling_category: dummy_type").
-lookup_tabling_category(type_info_type,
+lookup_tabling_category(type_cat_type_info,
yes("typeinfo" - table_trie_step_typeinfo)).
-lookup_tabling_category(type_ctor_info_type,
+lookup_tabling_category(type_cat_type_ctor_info,
yes("typeinfo" - table_trie_step_typeinfo)).
-lookup_tabling_category(typeclass_info_type, _) :-
+lookup_tabling_category(type_cat_typeclass_info, _) :-
unexpected(this_file, "lookup_tabling_category: typeclass_info_type").
-lookup_tabling_category(base_typeclass_info_type, _) :-
+lookup_tabling_category(type_cat_base_typeclass_info, _) :-
unexpected(this_file, "lookup_tabling_category: base_typeclass_info_type").
-lookup_tabling_category(enum_type, no).
-lookup_tabling_category(higher_order_type, no).
-lookup_tabling_category(tuple_type, no).
-lookup_tabling_category(variable_type, no).
-lookup_tabling_category(user_ctor_type, no).
-
-% Figure out which save and restore predicates in library/table_builtin.m
-% we need to use for values of types belonging the type category given by
-% the first argument. The returned value replaces CAT in table_save_CAT_answer
-% and table_restore_CAT_answer.
+lookup_tabling_category(type_cat_enum, no).
+lookup_tabling_category(type_cat_higher_order, no).
+lookup_tabling_category(type_cat_tuple, no).
+lookup_tabling_category(type_cat_variable, no).
+lookup_tabling_category(type_cat_user_ctor, no).
+
+ % Figure out which save and restore predicates in library/table_builtin.m
+ % we need to use for values of types belonging the type category given by
+ % the first argument. The returned value replaces CAT in
+ % table_save_CAT_answer and table_restore_CAT_answer.
:- pred type_save_category(type_category::in, string::out) is det.
-type_save_category(enum_type, "enum").
-type_save_category(int_type, "int").
-type_save_category(char_type, "char").
-type_save_category(str_type, "string").
-type_save_category(float_type, "float").
-type_save_category(higher_order_type, "pred").
-type_save_category(tuple_type, "any").
-type_save_category(user_ctor_type, "any"). % could do better
-type_save_category(variable_type, "any"). % could do better
-type_save_category(dummy_type, _) :-
+type_save_category(type_cat_enum, "enum").
+type_save_category(type_cat_int, "int").
+type_save_category(type_cat_char, "char").
+type_save_category(type_cat_string, "string").
+type_save_category(type_cat_float, "float").
+type_save_category(type_cat_higher_order, "pred").
+type_save_category(type_cat_tuple, "any").
+type_save_category(type_cat_user_ctor, "any"). % could do better
+type_save_category(type_cat_variable, "any"). % could do better
+type_save_category(type_cat_dummy, _) :-
unexpected(this_file, "type_save_category: dummy").
-type_save_category(void_type, _) :-
+type_save_category(type_cat_void, _) :-
unexpected(this_file, "type_save_category: void").
-type_save_category(type_info_type, "any"). % could do better
-type_save_category(type_ctor_info_type, _) :-
+type_save_category(type_cat_type_info, "any"). % could do better
+type_save_category(type_cat_type_ctor_info, _) :-
unexpected(this_file, "type_save_category: type_ctor_info").
-type_save_category(typeclass_info_type, _) :-
+type_save_category(type_cat_typeclass_info, _) :-
unexpected(this_file, "type_save_category: typeclass_info").
-type_save_category(base_typeclass_info_type, _) :-
+type_save_category(type_cat_base_typeclass_info, _) :-
unexpected(this_file, "type_save_category: base_typeclass_info").
%-----------------------------------------------------------------------------%
@@ -3443,37 +3448,27 @@
table_gen__make_type_info_vars(Types, Context, !VarTypes, !VarSet, !TableInfo,
TypeInfoVars, TypeInfoGoals) :-
- %
- % Extract the information from table_info
- %
+ % Extract the information from table_info.
table_info_extract(!.TableInfo, ModuleInfo0, PredInfo0, ProcInfo0),
- %
% Put the varset and vartypes from the simplify_info
- % back in the proc_info
- %
+ % back in the proc_info.
proc_info_set_vartypes(!.VarTypes, ProcInfo0, ProcInfo1),
proc_info_set_varset(!.VarSet, ProcInfo1, ProcInfo2),
- %
- % Call polymorphism.m to create the type_infos
- %
+ % Call polymorphism.m to create the type_infos.
create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2, PolyInfo0),
polymorphism__make_type_info_vars(Types, Context,
TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo),
poly_info_extract(PolyInfo, PredInfo0, PredInfo,
ProcInfo0, ProcInfo, ModuleInfo),
- %
- % Get the new varset and vartypes from the proc_info
- %
+ % Get the new varset and vartypes from the proc_info.
proc_info_vartypes(ProcInfo, !:VarTypes),
proc_info_varset(ProcInfo, !:VarSet),
- %
% Put the new module_info, pred_info, and proc_info back in the
% table_info.
- %
table_info_init(ModuleInfo, PredInfo, ProcInfo, !:TableInfo).
%-----------------------------------------------------------------------------%
@@ -3494,7 +3489,7 @@
table_gen__var_is_io_state(VarTypes, Var) :-
map__lookup(VarTypes, Var, VarType),
- type_util__type_is_io_state(VarType).
+ type_is_io_state(VarType).
%-----------------------------------------------------------------------------%
Index: compiler/tag_switch.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/tag_switch.m,v
retrieving revision 1.66
diff -u -b -r1.66 tag_switch.m
--- compiler/tag_switch.m 28 Oct 2005 02:10:38 -0000 1.66
+++ compiler/tag_switch.m 1 Nov 2005 10:24:01 -0000
@@ -18,7 +18,6 @@
:- import_module backend_libs.switch_util.
:- import_module hlds.code_model.
-:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module ll_backend.code_info.
:- import_module ll_backend.llds.
@@ -37,6 +36,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_out.
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.15
diff -u -b -r1.15 term_norm.m
--- compiler/term_norm.m 28 Oct 2005 14:00:34 -0000 1.15
+++ compiler/term_norm.m 1 Nov 2005 06:05:16 -0000
@@ -339,21 +339,21 @@
:- pred zero_size_type_category(type_category::in, bool::out) is det.
-zero_size_type_category(int_type, yes).
-zero_size_type_category(char_type, yes).
-zero_size_type_category(str_type, yes).
-zero_size_type_category(float_type, yes).
-zero_size_type_category(void_type, yes).
-zero_size_type_category(type_info_type, yes).
-zero_size_type_category(type_ctor_info_type, yes).
-zero_size_type_category(typeclass_info_type, yes).
-zero_size_type_category(base_typeclass_info_type, yes).
-zero_size_type_category(higher_order_type, yes).
-zero_size_type_category(tuple_type, no).
-zero_size_type_category(enum_type, yes).
-zero_size_type_category(dummy_type, yes).
-zero_size_type_category(variable_type, no).
-zero_size_type_category(user_ctor_type, no).
+zero_size_type_category(type_cat_int, yes).
+zero_size_type_category(type_cat_char, yes).
+zero_size_type_category(type_cat_string, yes).
+zero_size_type_category(type_cat_float, yes).
+zero_size_type_category(type_cat_void, yes).
+zero_size_type_category(type_cat_type_info, yes).
+zero_size_type_category(type_cat_type_ctor_info, yes).
+zero_size_type_category(type_cat_typeclass_info, yes).
+zero_size_type_category(type_cat_base_typeclass_info, yes).
+zero_size_type_category(type_cat_higher_order, yes).
+zero_size_type_category(type_cat_tuple, no).
+zero_size_type_category(type_cat_enum, yes).
+zero_size_type_category(type_cat_dummy, yes).
+zero_size_type_category(type_cat_variable, no).
+zero_size_type_category(type_cat_user_ctor, no).
%-----------------------------------------------------------------------------%
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.159
diff -u -b -r1.159 type_util.m
--- compiler/type_util.m 28 Oct 2005 02:10:41 -0000 1.159
+++ compiler/type_util.m 1 Nov 2005 09:41:05 -0000
@@ -22,16 +22,12 @@
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
-:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_type.
-:- import_module bool.
:- import_module list.
-:- import_module map.
:- import_module std_util.
-:- import_module term.
%-----------------------------------------------------------------------------%
@@ -42,11 +38,6 @@
:- pred type_ctor_is_atomic(type_ctor::in, module_info::in) is semidet.
- % The list of type_ctors which are builtins which do not have a
- % hlds_type_defn.
- %
-:- func builtin_type_ctors_with_no_hlds_type_defn = list(type_ctor).
-
% Obtain the type definition and type definition body respectively,
% if known, for the principal type constructor of the given type.
%
@@ -108,19 +99,6 @@
% dummy type, or it has only a single function symbol of arity zero.
%
:- pred is_dummy_argument_type(module_info::in, mer_type::in) is semidet.
-:- pred constructor_list_represents_dummy_argument_type(list(constructor)::in,
- maybe(unify_compare)::in) is semidet.
-
-:- pred type_is_io_state(mer_type::in) is semidet.
-
-:- pred type_is_aditi_state(mer_type::in) is semidet.
-
-:- pred type_ctor_is_array(type_ctor::in) is semidet.
-
- % Remove an `aditi:state' from the given list if one is present.
- %
-:- pred remove_aditi_state(list(mer_type)::in, list(T)::in, list(T)::out)
- is det.
% A test for types that are defined in Mercury, but whose definitions
% are `lies', i.e. they are not sufficiently accurate for RTTI
@@ -130,37 +108,6 @@
:- pred type_ctor_has_hand_defined_rtti(type_ctor::in, hlds_type_body::in)
is semidet.
- % A test for type_info-related types that are introduced by
- % polymorphism.m. These need to be handled specially in certain
- % places. For example, mode inference never infers unique modes
- % for these types, since it would not be useful, and since we
- % want to minimize the number of different modes that we infer.
- %
-:- pred is_introduced_type_info_type(mer_type::in) is semidet.
-
-:- pred is_introduced_type_info_type_ctor(type_ctor::in) is semidet.
-
-:- func is_introduced_type_info_type_category(type_category) = bool.
-
- % Given a list of variables, return the permutation
- % of that list which has all the type_info-related variables
- % preceding the non-type_info-related variables (with the relative
- % order of variables within each group being the same as in the
- % original list).
- %
-:- func put_typeinfo_vars_first(list(prog_var), vartypes) = list(prog_var).
-
- % In the forwards mode, this predicate checks for a "new " prefix
- % at the start of the functor name, and removes it if present;
- % it fails if there is no such prefix.
- % In the reverse mode, this predicate prepends such a prefix.
- % (These prefixes are used for construction unifications
- % with existentially typed functors.)
- %
-:- pred remove_new_prefix(sym_name, sym_name).
-:- mode remove_new_prefix(in, out) is semidet.
-:- mode remove_new_prefix(out, in) is det.
-
% Given a type, determine what category its principal constructor
% falls into.
%
@@ -170,57 +117,14 @@
%
:- func classify_type_ctor(module_info, type_ctor) = type_category.
-:- type type_category
- ---> int_type
- ; char_type
- ; str_type
- ; float_type
- ; higher_order_type
- ; tuple_type
- ; enum_type
- ; dummy_type
- ; variable_type
- ; type_info_type
- ; type_ctor_info_type
- ; typeclass_info_type
- ; base_typeclass_info_type
- ; void_type
- ; user_ctor_type.
-
- % Construct builtin types.
- %
-:- func int_type = mer_type.
-:- func string_type = mer_type.
-:- func float_type = mer_type.
-:- func char_type = mer_type.
-:- func void_type = mer_type.
-:- func c_pointer_type = mer_type.
-:- func heap_pointer_type = mer_type.
-:- func sample_type_info_type = mer_type.
-:- func sample_typeclass_info_type = mer_type.
-:- func comparison_result_type = mer_type.
-:- func aditi_state_type = mer_type.
-
- % Construct the types of type_infos and type_ctor_infos.
- %
-:- func type_info_type = mer_type.
-:- func type_ctor_info_type = mer_type.
-
- % Given a constant and an arity, return a type_ctor.
- % Fails if the constant is not an atom.
- %
-:- pred make_type_ctor(const::in, int::in, type_ctor::out) is semidet.
-
% Given a type_ctor, look up its module/name/arity
%
:- pred type_ctor_module(module_info::in, type_ctor::in,
module_name::out) is det.
-:- pred type_ctor_name(module_info::in, type_ctor::in, string::out)
- is det.
+:- pred type_ctor_name(module_info::in, type_ctor::in, string::out) is det.
-:- pred type_ctor_arity(module_info::in, type_ctor::in, arity::out)
- is det.
+:- pred type_ctor_arity(module_info::in, type_ctor::in, arity::out) is det.
% If the type is a du type or a tuple type, return the list of its
% constructors.
@@ -276,16 +180,6 @@
:- pred get_cons_defn(module_info::in, type_ctor::in, cons_id::in,
hlds_cons_defn::out) is semidet.
- % Module-qualify the cons_id using module information from the type.
- % The second output value is the cons_id required for use in insts which
- % can be different from that used in types for typeclass_info and
- % type_info. The list(prog_var) is the list of arguments to the cons_id
- % and is just used for obtaining the arity for typeclass_info and type_info
- % cons_ids.
- %
-:- pred qualify_cons_id(mer_type::in, list(prog_var)::in, cons_id::in,
- cons_id::out, cons_id::out) is det.
-
% Given a type and a cons_id, look up the definition of that constructor;
% if it is existentially typed, return its definition, otherwise fail.
% Note that this will NOT bind type variables in the functor's argument
@@ -293,28 +187,10 @@
% original types from the constructor definition. The caller must do
% that substitution itself if required.
%
-:- pred get_existq_cons_defn(module_info::in, mer_type::in,
- cons_id::in, ctor_defn::out) is semidet.
-
-:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in)
- is semidet.
+:- pred get_existq_cons_defn(module_info::in, mer_type::in, cons_id::in,
+ ctor_defn::out) is semidet.
- % This type is used to return information about a constructor definition,
- % extracted from the hlds_type_defn and hlds_cons_defn data types.
- %
-:- type ctor_defn
- ---> ctor_defn(
- ctor_tvars :: tvarset,
- ctor_existq_tvars :: existq_tvars,
- ctor_tvar_kinds :: tvar_kind_map,
- % kinds of existq_tvars
- ctor_constraints :: list(prog_constraint),
- % existential constraints
- ctor_arg_types :: list(mer_type),
- % functor argument types
- ctor_result_type :: mer_type
- % functor result type
- ).
+:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in) is semidet.
% Check whether a type is a no_tag type (i.e. one with only one
% constructor, and whose one constructor has only one argument),
@@ -323,106 +199,67 @@
:- pred type_is_no_tag_type(module_info::in, mer_type::in, sym_name::out,
mer_type::out) is semidet.
- % Check whether the type with the given list of constructors would be
- % a no_tag type (which requires the list to include exactly one constructor
- % with exactly one argument), and if so, return its constructor symbol,
- % argument type, and the argument's name (if it has one).
- %
- % This doesn't do any checks for options that might be set (such as
- % turning off no_tag_types). If you want those checks you should use
- % type_is_no_tag_type/4, or if you really know what you are doing,
- % perform the checks yourself.
+ % cons_id_adjusted_arity(ModuleInfo, Type, ConsId):
%
-:- pred type_constructors_are_no_tag_type(list(constructor)::in, sym_name::out,
- mer_type::out, maybe(string)::out) is semidet.
-
- % Given a list of constructors for a type, check whether that type
- % is a private_builtin.type_info/0 or similar type.
+ % 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.
%
-:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
+:- func cons_id_adjusted_arity(module_info, mer_type, cons_id) = int.
- % type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReservedTag,
- % Ctors, UserEqComp, FunctorName, FunctorArgType, MaybeFunctorArgName):
- %
- % Check whether some constructors are a no_tag type, and that this
- % is compatible with the ReservedTag setting for this type and
- % the grade options set in the globals.
- % Assign single functor of arity one a `no_tag' tag (unless we are
- % reserving a tag, or if it is one of the dummy types).
- %
-:- pred type_with_constructors_should_be_no_tag(globals::in, type_ctor::in,
- bool::in, list(constructor)::in, maybe(unify_compare)::in, sym_name::out,
- mer_type::out, maybe(string)::out) is semidet.
+%-----------------------------------------------------------------------------%
- % Unify (with occurs check) two types with respect to a type substitution
- % and update the type bindings. The third argument is a list of type
- % variables which cannot be bound (i.e. head type variables).
- %
- % No kind checking is done, since it is assumed that kind errors
- % will be picked up elsewhere.
+ % If possible, get the argument types for the cons_id. We need to pass in
+ % the arity rather than using the arity from the cons_id because the arity
+ % in the cons_id will not include any extra type_info arguments for
+ % existentially quantified types.
%
-:- pred type_unify(mer_type::in, mer_type::in, list(tvar)::in, tsubst::in,
- tsubst::out) is semidet.
+:- pred maybe_get_cons_id_arg_types(module_info::in, maybe(mer_type)::in,
+ cons_id::in, arity::in, list(maybe(mer_type))::out) is det.
-:- pred type_unify_list(list(mer_type)::in, list(mer_type)::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
+:- pred maybe_get_higher_order_arg_types(maybe(mer_type)::in, arity::in,
+ list(maybe(mer_type))::out) is det.
- % type_list_subsumes(TypesA, TypesB, Subst) succeeds iff the list
- % TypesA subsumes (is more general than) TypesB, producing a
- % type substitution which when applied to TypesA will give TypesB.
- %
-:- pred type_list_subsumes(list(mer_type)::in, list(mer_type)::in, tsubst::out)
- is semidet.
+%-----------------------------------------------------------------------------%
+%
+% Predicates for doing renamings and substitutions on HLDS data structures.
+%
- % This does the same as type_list_subsumes, but aborts instead of failing.
- %
-:- pred type_list_subsumes_det(list(mer_type)::in, list(mer_type)::in,
- tsubst::out) is det.
+:- pred apply_variable_renaming_to_constraint(tvar_renaming::in,
+ hlds_constraint::in, hlds_constraint::out) is det.
- % arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
- % CalleeExistQVars, CalleeArgTypes):
- %
- % Check that the argument types of the called predicate, function or
- % constructor subsume the types of the arguments of the call. This checks
- % that none of the existentially quantified type variables of the callee
- % are bound.
- %
-:- pred arg_type_list_subsumes(tvarset::in, list(mer_type)::in, tvarset::in,
- tvar_kind_map::in, existq_tvars::in, list(mer_type)::in) is semidet.
+:- pred apply_subst_to_constraint(tsubst::in, hlds_constraint::in,
+ hlds_constraint::out) is det.
- % Apply a type substitution (i.e. map from tvar -> type)
- % to all the types in a variable typing (i.e. map from var -> type).
- %
-:- pred apply_subst_to_type_map(tsubst::in, vartypes::in, vartypes::out)
- is det.
+:- pred apply_rec_subst_to_constraint(tsubst::in, hlds_constraint::in,
+ hlds_constraint::out) is det.
- % Same thing as above, except for a recursive substitution
- % (i.e. we keep applying the substitution recursively until
- % there are no more changes).
- %
-:- pred apply_rec_subst_to_type_map(tsubst::in, vartypes::in, vartypes::out)
- is det.
+%-------------%
-:- pred apply_variable_renaming_to_type_map(tvar_renaming::in,
- vartypes::in, vartypes::out) is det.
+:- pred apply_variable_renaming_to_constraint_list(tvar_renaming::in,
+ list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
-:- pred apply_rec_subst_to_constraints(tsubst::in, hlds_constraints::in,
- hlds_constraints::out) is det.
+:- pred apply_subst_to_constraint_list(tsubst::in, list(hlds_constraint)::in,
+ list(hlds_constraint)::out) is det.
:- pred apply_rec_subst_to_constraint_list(tsubst::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
-:- pred apply_rec_subst_to_constraint(tsubst::in, hlds_constraint::in,
- hlds_constraint::out) is det.
+%-------------%
+
+:- pred apply_variable_renaming_to_constraints(tvar_renaming::in,
+ hlds_constraints::in, hlds_constraints::out) is det.
:- pred apply_subst_to_constraints(tsubst::in, hlds_constraints::in,
hlds_constraints::out) is det.
-:- pred apply_subst_to_constraint_list(tsubst::in, list(hlds_constraint)::in,
- list(hlds_constraint)::out) is det.
+:- pred apply_rec_subst_to_constraints(tsubst::in, hlds_constraints::in,
+ hlds_constraints::out) is det.
-:- pred apply_subst_to_constraint(tsubst::in, hlds_constraint::in,
- hlds_constraint::out) is det.
+%-------------%
+
+:- pred apply_variable_renaming_to_constraint_proofs(tvar_renaming::in,
+ constraint_proof_map::in, constraint_proof_map::out) is det.
:- pred apply_subst_to_constraint_proofs(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
@@ -430,61 +267,16 @@
:- pred apply_rec_subst_to_constraint_proofs(tsubst::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
-:- pred apply_subst_to_constraint_map(tsubst::in,
- constraint_map::in, constraint_map::out) is det.
-
-:- pred apply_rec_subst_to_constraint_map(tsubst::in,
- constraint_map::in, constraint_map::out) is det.
-
-:- pred apply_variable_renaming_to_constraints(tvar_renaming::in,
- hlds_constraints::in, hlds_constraints::out) is det.
-
-:- pred apply_variable_renaming_to_constraint_list(tvar_renaming::in,
- list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
-
-:- pred apply_variable_renaming_to_constraint(tvar_renaming::in,
- hlds_constraint::in, hlds_constraint::out) is det.
-
-:- pred apply_variable_renaming_to_constraint_proofs(tvar_renaming::in,
- constraint_proof_map::in, constraint_proof_map::out) is det.
+%-------------%
:- pred apply_variable_renaming_to_constraint_map(tvar_renaming::in,
constraint_map::in, constraint_map::out) is det.
- % Apply a renaming (partial map) to a list.
- % Useful for applying a variable renaming to a list of variables.
- %
-:- pred apply_partial_map_to_list(list(T)::in, map(T, T)::in, list(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, mer_type, cons_id) = int.
-
-%-----------------------------------------------------------------------------%
-
- % If possible, get the argument types for the cons_id. We need to pass in
- % the arity rather than using the arity from the cons_id because the arity
- % in the cons_id will not include any extra type_info arguments for
- % existentially quantified types.
- %
-:- pred maybe_get_cons_id_arg_types(module_info::in, maybe(mer_type)::in,
- cons_id::in, arity::in, list(maybe(mer_type))::out) is det.
-
-:- pred maybe_get_higher_order_arg_types(maybe(mer_type)::in, arity::in,
- list(maybe(mer_type))::out) is det.
-
-:- type polymorphism_cell
- ---> type_info_cell(type_ctor)
- ; typeclass_info_cell.
-
-:- func cell_cons_id(polymorphism_cell) = cons_id.
+:- pred apply_subst_to_constraint_map(tsubst::in,
+ constraint_map::in, constraint_map::out) is det.
-:- func cell_inst_cons_id(polymorphism_cell, int) = cons_id.
+:- pred apply_rec_subst_to_constraint_map(tsubst::in,
+ constraint_map::in, constraint_map::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -495,17 +287,20 @@
:- import_module backend_libs.foreign.
:- import_module check_hlds.purity.
:- import_module hlds.hlds_out.
+:- import_module libs.globals.
:- import_module libs.options.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_io_goal.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
:- import_module char.
:- import_module int.
+:- import_module map.
:- import_module require.
:- import_module string.
:- import_module svmap.
@@ -529,23 +324,21 @@
:- func type_category_is_atomic(type_category) = bool.
-type_category_is_atomic(int_type) = yes.
-type_category_is_atomic(char_type) = yes.
-type_category_is_atomic(str_type) = yes.
-type_category_is_atomic(float_type) = yes.
-type_category_is_atomic(higher_order_type) = no.
-type_category_is_atomic(tuple_type) = no.
-type_category_is_atomic(enum_type) = yes.
-type_category_is_atomic(dummy_type) = yes.
-type_category_is_atomic(variable_type) = no.
-type_category_is_atomic(type_info_type) = no.
-type_category_is_atomic(type_ctor_info_type) = no.
-type_category_is_atomic(typeclass_info_type) = no.
-type_category_is_atomic(base_typeclass_info_type) = no.
-type_category_is_atomic(void_type) = yes.
-type_category_is_atomic(user_ctor_type) = no.
-
-type_ctor_is_array(qualified(unqualified("array"), "array") - 1).
+type_category_is_atomic(type_cat_int) = yes.
+type_category_is_atomic(type_cat_char) = yes.
+type_category_is_atomic(type_cat_string) = yes.
+type_category_is_atomic(type_cat_float) = yes.
+type_category_is_atomic(type_cat_higher_order) = no.
+type_category_is_atomic(type_cat_tuple) = no.
+type_category_is_atomic(type_cat_enum) = yes.
+type_category_is_atomic(type_cat_dummy) = yes.
+type_category_is_atomic(type_cat_variable) = no.
+type_category_is_atomic(type_cat_type_info) = no.
+type_category_is_atomic(type_cat_type_ctor_info) = no.
+type_category_is_atomic(type_cat_typeclass_info) = no.
+type_category_is_atomic(type_cat_base_typeclass_info) = no.
+type_category_is_atomic(type_cat_void) = yes.
+type_category_is_atomic(type_cat_user_ctor) = no.
type_ctor_has_hand_defined_rtti(Type, Body) :-
Type = qualified(mercury_private_builtin_module, Name) - 0,
@@ -559,86 +352,43 @@
; Body = solver_type(_, _)
).
-is_introduced_type_info_type(Type) :-
- type_to_ctor_and_args(Type, TypeCtor, _),
- is_introduced_type_info_type_ctor(TypeCtor).
-
-is_introduced_type_info_type_ctor(TypeCtor) :-
- TypeCtor = qualified(PrivateBuiltin, Name) - 0,
- mercury_private_builtin_module(PrivateBuiltin),
- ( Name = "type_info"
- ; Name = "type_ctor_info"
- ; Name = "typeclass_info"
- ; Name = "base_typeclass_info"
- ).
-
-is_introduced_type_info_type_category(int_type) = no.
-is_introduced_type_info_type_category(char_type) = no.
-is_introduced_type_info_type_category(str_type) = no.
-is_introduced_type_info_type_category(float_type) = no.
-is_introduced_type_info_type_category(higher_order_type) = no.
-is_introduced_type_info_type_category(tuple_type) = no.
-is_introduced_type_info_type_category(enum_type) = no.
-is_introduced_type_info_type_category(dummy_type) = no.
-is_introduced_type_info_type_category(variable_type) = no.
-is_introduced_type_info_type_category(type_info_type) = yes.
-is_introduced_type_info_type_category(type_ctor_info_type) = yes.
-is_introduced_type_info_type_category(typeclass_info_type) = yes.
-is_introduced_type_info_type_category(base_typeclass_info_type) = yes.
-is_introduced_type_info_type_category(void_type) = no.
-is_introduced_type_info_type_category(user_ctor_type) = no.
-
-put_typeinfo_vars_first(VarsList, VarTypes) =
- TypeInfoVarsList ++ NonTypeInfoVarsList :-
- list__filter((pred(Var::in) is semidet :-
- Type = map__lookup(VarTypes, Var),
- is_introduced_type_info_type(Type)),
- VarsList, TypeInfoVarsList, NonTypeInfoVarsList).
-
-remove_new_prefix(unqualified(Name0), unqualified(Name)) :-
- string__append("new ", Name, Name0).
-remove_new_prefix(qualified(Module, Name0), qualified(Module, Name)) :-
- string__append("new ", Name, Name0).
-
%-----------------------------------------------------------------------------%
- % Given a type, determine what sort of type it is.
-
classify_type(ModuleInfo, VarType) = TypeCategory :-
( type_to_ctor_and_args(VarType, TypeCtor, _) ->
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
;
- TypeCategory = variable_type
+ TypeCategory = type_cat_variable
).
classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
PrivateBuiltin = mercury_private_builtin_module,
( TypeCtor = unqualified("character") - 0 ->
- TypeCategory = char_type
+ TypeCategory = type_cat_char
; TypeCtor = unqualified("int") - 0 ->
- TypeCategory = int_type
+ TypeCategory = type_cat_int
; TypeCtor = unqualified("float") - 0 ->
- TypeCategory = float_type
+ TypeCategory = type_cat_float
; TypeCtor = unqualified("string") - 0 ->
- TypeCategory = str_type
+ TypeCategory = type_cat_string
; TypeCtor = unqualified("void") - 0 ->
- TypeCategory = void_type
+ TypeCategory = type_cat_void
; TypeCtor = qualified(PrivateBuiltin, "type_info") - 0 ->
- TypeCategory = type_info_type
+ TypeCategory = type_cat_type_info
; TypeCtor = qualified(PrivateBuiltin, "type_ctor_info") - 0 ->
- TypeCategory = type_ctor_info_type
+ TypeCategory = type_cat_type_ctor_info
; TypeCtor = qualified(PrivateBuiltin, "typeclass_info") - 0 ->
- TypeCategory = typeclass_info_type
+ TypeCategory = type_cat_typeclass_info
; TypeCtor = qualified(PrivateBuiltin, "base_typeclass_info") - 0 ->
- TypeCategory = base_typeclass_info_type
+ TypeCategory = type_cat_base_typeclass_info
; type_ctor_is_higher_order(TypeCtor, _, _, _) ->
- TypeCategory = higher_order_type
+ TypeCategory = type_cat_higher_order
; type_ctor_is_tuple(TypeCtor) ->
- TypeCategory = tuple_type
+ TypeCategory = type_cat_tuple
; type_ctor_is_enumeration(TypeCtor, ModuleInfo) ->
- TypeCategory = enum_type
+ TypeCategory = type_cat_enum
;
- TypeCategory = user_ctor_type
+ TypeCategory = type_cat_user_ctor
).
type_has_user_defined_equality_pred(ModuleInfo, Type, UserEqComp) :-
@@ -730,19 +480,6 @@
Constructor ^ cons_exist \= []
).
-:- pred is_dummy_argument_type_with_constructors(type_ctor::in,
- list(constructor)::in, maybe(unify_compare)::in) is semidet.
-
-is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp) :-
- % Keep this in sync with is_dummy_argument_type below.
- (
- TypeCtor = CtorSymName - TypeArity,
- CtorSymName = qualified(unqualified(ModuleName), TypeName),
- is_builtin_dummy_argument_type(ModuleName, TypeName, TypeArity)
- ;
- constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
- ).
-
is_dummy_argument_type(ModuleInfo, Type) :-
( type_to_ctor_and_args(Type, TypeCtor, _) ->
% Keep this in sync with is_dummy_argument_type_with_constructors
@@ -765,37 +502,6 @@
fail
).
-:- pred is_builtin_dummy_argument_type(string::in, string::in, arity::in)
- is semidet.
-
-is_builtin_dummy_argument_type("io", "state", 0). % io.state/0
-is_builtin_dummy_argument_type("store", "store", 1). % store.store/1.
-% XXX should we include aditi.state/0 in this list?
-
-constructor_list_represents_dummy_argument_type([Ctor], no) :-
- Ctor = ctor([], [], _, []).
-
-type_is_io_state(Type) :-
- type_to_ctor_and_args(Type, TypeCtor, []),
- TypeCtor = qualified(unqualified("io"), "state") - 0.
-
-type_is_aditi_state(Type) :-
- type_to_ctor_and_args(Type, TypeCtor, []),
- TypeCtor = qualified(unqualified("aditi"), "state") - 0.
-
-remove_aditi_state([], [], []).
-remove_aditi_state([], [_ | _], _) :-
- error("gremove_aditi_state").
-remove_aditi_state([_ | _], [], _) :-
- error("gremove_aditi_state").
-remove_aditi_state([Type | Types], [Arg | Args0], Args) :-
- ( type_is_aditi_state(Type) ->
- remove_aditi_state(Types, Args0, Args)
- ;
- remove_aditi_state(Types, Args0, Args1),
- Args = [Arg | Args1]
- ).
-
:- pred type_ctor_is_enumeration(type_ctor::in, module_info::in) is semidet.
type_ctor_is_enumeration(TypeCtor, ModuleInfo) :-
@@ -804,57 +510,6 @@
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
TypeBody ^ du_type_is_enum = is_enum.
-int_type = builtin(int).
-
-string_type = builtin(string).
-
-float_type = builtin(float).
-
-char_type = builtin(character).
-
-void_type = defined(unqualified("void"), [], star).
-
-c_pointer_type = defined(Name, [], star) :-
- mercury_public_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "c_pointer").
-
-heap_pointer_type = defined(Name, [], star) :-
- mercury_private_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "heap_pointer").
-
-sample_type_info_type = defined(Name, [], star) :-
- mercury_private_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "sample_type_info").
-
-sample_typeclass_info_type = defined(Name, [], star) :-
- mercury_private_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "sample_typeclass_info").
-
-comparison_result_type = defined(Name, [], star) :-
- mercury_public_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "comparison_result").
-
-type_info_type = defined(Name, [], star) :-
- mercury_private_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "type_info").
-
-type_ctor_info_type = defined(Name, [], star) :-
- mercury_private_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "type_ctor_info").
-
-aditi_state_type = defined(Name, [], star) :-
- aditi_public_builtin_module(BuiltinModule),
- Name = qualified(BuiltinModule, "state").
-
-%-----------------------------------------------------------------------------%
-
- % Given a constant and an arity, return a type_ctor.
- % This really ought to take a name and an arity -
- % use of integers/floats/strings as type names should
- % be rejected by the parser in prog_io.m, not in module_qual.m.
-
-make_type_ctor(term__atom(Name), Arity, unqualified(Name) - Arity).
-
%-----------------------------------------------------------------------------%
% If the type is a du type, return the list of its constructors.
@@ -1041,34 +696,6 @@
%-----------------------------------------------------------------------------%
-qualify_cons_id(Type, Args, ConsId0, ConsId, InstConsId) :-
- (
- ConsId0 = cons(Name0, OrigArity),
- type_to_ctor_and_args(Type, TypeCtor, _),
- TypeCtor = qualified(TypeModule, _) - _
- ->
- unqualify_name(Name0, UnqualName),
- Name = qualified(TypeModule, UnqualName),
- ConsId = cons(Name, OrigArity),
- InstConsId = ConsId
- ;
- ConsId0 = type_info_cell_constructor(CellCtor)
- ->
- ConsId = ConsId0,
- InstConsId = cell_inst_cons_id(type_info_cell(CellCtor),
- list__length(Args))
- ;
- ConsId0 = typeclass_info_cell_constructor
- ->
- ConsId = typeclass_info_cell_constructor,
- InstConsId = cell_inst_cons_id(typeclass_info_cell, list__length(Args))
- ;
- ConsId = ConsId0,
- InstConsId = ConsId
- ).
-
-%-----------------------------------------------------------------------------%
-
type_is_no_tag_type(ModuleInfo, Type, Ctor, ArgType) :-
type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
module_info_get_no_tag_types(ModuleInfo, NoTagTypes),
@@ -1083,74 +710,6 @@
apply_subst_to_type(Subn, ArgType0, ArgType)
).
-type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :-
- type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName0, ArgType),
-
- % We don't handle unary tuples as no_tag types -- they are rare enough
- % that it's not worth the implementation effort.
- Ctor \= unqualified("{}"),
-
- map_maybe(unqualify_name, MaybeArgName0, MaybeArgName).
-
-type_constructors_are_type_info(Ctors) :-
- type_is_single_ctor_single_arg(Ctors, Ctor, _, _),
- ctor_is_type_info(Ctor).
-
-:- pred ctor_is_type_info(sym_name::in) is semidet.
-
-ctor_is_type_info(Ctor) :-
- unqualify_private_builtin(Ctor, Name),
- name_is_type_info(Name).
-
-:- pred name_is_type_info(string::in) is semidet.
-
-name_is_type_info("type_info").
-name_is_type_info("type_ctor_info").
-name_is_type_info("typeclass_info").
-name_is_type_info("base_typeclass_info").
-
- % If the sym_name is in the private_builtin module, unqualify it,
- % otherwise fail. All, user-defined types should be module-qualified
- % by the time this predicate is called, so we assume that any unqualified
- % names are in private_builtin.
- %
-:- pred unqualify_private_builtin(sym_name::in, string::out) is semidet.
-
-unqualify_private_builtin(unqualified(Name), Name).
-unqualify_private_builtin(qualified(ModuleName, Name), Name) :-
- mercury_private_builtin_module(ModuleName).
-
-:- pred type_is_single_ctor_single_arg(list(constructor)::in, sym_name::out,
- maybe(ctor_field_name)::out, mer_type::out) is semidet.
-
-type_is_single_ctor_single_arg(Ctors, Ctor, MaybeArgName, ArgType) :-
- Ctors = [SingleCtor],
- SingleCtor = ctor(ExistQVars, _Constraints, Ctor,
- [MaybeArgName - ArgType]),
- ExistQVars = [].
-
-%-----------------------------------------------------------------------------%
-
- % Assign single functor of arity one a `no_tag' tag (unless we are
- % reserving a tag, or if it is one of the dummy types).
- %
-type_with_constructors_should_be_no_tag(Globals, TypeCtor, ReserveTagPragma,
- Ctors, UserEqCmp, SingleFunc, SingleArg, MaybeArgName) :-
- type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg,
- MaybeArgName),
- (
- ReserveTagPragma = no,
- globals__lookup_bool_option(Globals, reserve_tag, no),
- globals__lookup_bool_option(Globals, unboxed_no_tag_types, yes)
- ;
- % Dummy types always need to be treated as no-tag types as the
- % low-level C back end just passes around rubbish for them. When e.g.
- % using the debugger, it is crucial that these values are treated
- % as unboxed c_pointers, not as tagged pointers to c_pointers
- % (otherwise the system winds up following a bogus pointer).
- is_dummy_argument_type_with_constructors(TypeCtor, Ctors, UserEqCmp)
- ).
-
%-----------------------------------------------------------------------------%
% Substitute the actual values of the type parameters in list of
@@ -1193,387 +752,98 @@
substitute_type_args_3(Subst, Args0, Args).
%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-type_list_subsumes(TypesA, TypesB, TypeSubst) :-
- %
- % TypesA subsumes TypesB iff TypesA can be unified with TypesB
- % without binding any of the type variables in TypesB.
- %
- prog_type__vars_list(TypesB, TypesBVars),
- map__init(TypeSubst0),
- type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
-
-type_list_subsumes_det(TypesA, TypesB, TypeSubst) :-
- ( type_list_subsumes(TypesA, TypesB, TypeSubstPrime) ->
- TypeSubst = TypeSubstPrime
- ;
- error("type_list_subsumes_det: type_list_subsumes failed")
- ).
-
-arg_type_list_subsumes(TVarSet, ActualArgTypes, CalleeTVarSet, PredKindMap,
- PredExistQVars, PredArgTypes) :-
- % Rename the type variables in the callee's argument types.
- tvarset_merge_renaming(TVarSet, CalleeTVarSet, _TVarSet1, Renaming),
- apply_variable_renaming_to_tvar_kind_map(Renaming, PredKindMap,
- ParentKindMap),
- apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
- ParentArgTypes),
- apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
- ParentExistQVars),
-
- % Check that the types of the candidate predicate/function
- % subsume the actual argument types.
- % [This is the right thing to do even for calls to
- % existentially typed preds, because we're using the
- % type variables from the callee's pred decl (obtained
- % from the pred_info via pred_info_arg_types) not the types
- % inferred from the callee's clauses (and stored in the
- % clauses_info and proc_info) -- the latter
- % might not subsume the actual argument types.]
-
- type_list_subsumes(ParentArgTypes, ActualArgTypes, ParentToActualSubst),
-
- % Check that the type substitution did not bind any existentially
- % typed variables to non-ground types.
- (
- ParentExistQVars = []
- % Optimize common case.
+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.
+ ConsArity = cons_id_arity(ConsId),
+ ( get_existq_cons_defn(ModuleInfo, Type, ConsId, ConsDefn) ->
+ ConsDefn = ctor_defn(_TVarSet, ExistQTVars, _KindMap,
+ 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
;
- ParentExistQVars = [_ | _],
- apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualSubst,
- ParentExistQVars, ActualExistQTypes),
- all [T] (list__member(T, ActualExistQTypes) => T = variable(_, _))
-
- % It might make sense to also check that the type substitution
- % did not bind any existentially typed variables to universally
- % quantified type variables in the caller's argument types.
+ AdjustedArity = ConsArity
).
%-----------------------------------------------------------------------------%
-%
-% Type unification.
-%
-
-type_unify(X, Y, HeadTypeParams, !Bindings) :-
- ( X = variable(VarX, _) ->
- type_unify_var(VarX, Y, HeadTypeParams, !Bindings)
- ; Y = variable(VarY, _) ->
- type_unify_var(VarY, X, HeadTypeParams, !Bindings)
- ; type_unify_nonvar(X, Y, HeadTypeParams, !Bindings) ->
- true
- ;
- % Some special cases are not handled above. We handle them separately
- % here.
- type_unify_special(X, Y, HeadTypeParams, !Bindings)
- ).
-
-:- pred type_unify_var(tvar::in, mer_type::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-
-type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings) :-
- ( TypeY = variable(VarY, KindY) ->
- type_unify_var_var(VarX, VarY, KindY, HeadTypeParams, !Bindings)
- ; map.search(!.Bindings, VarX, BindingOfX) ->
- % VarX has a binding. Y is not a variable.
- type_unify(BindingOfX, TypeY, HeadTypeParams, !Bindings)
- ;
- % VarX has no binding, so bind it to TypeY.
- \+ type_occurs(TypeY, VarX, !.Bindings),
- \+ list.member(VarX, HeadTypeParams),
- svmap.det_insert(VarX, TypeY, !Bindings)
- ).
-
-:- pred type_unify_var_var(tvar::in, tvar::in, kind::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-type_unify_var_var(X, Y, Kind, HeadTypeParams, !Bindings) :-
- ( list.member(Y, HeadTypeParams) ->
- type_unify_head_type_param(X, Y, Kind, HeadTypeParams, !Bindings)
- ; list.member(X, HeadTypeParams) ->
- type_unify_head_type_param(Y, X, Kind, HeadTypeParams, !Bindings)
- ; map.search(!.Bindings, X, BindingOfX) ->
- ( map.search(!.Bindings, Y, BindingOfY) ->
- % Both X and Y already have bindings - just unify the
- % types they are bound to.
- type_unify(BindingOfX, BindingOfY, HeadTypeParams, !Bindings)
- ;
- % Y hasn't been bound yet.
- apply_rec_subst_to_type(!.Bindings, BindingOfX, SubstBindingOfX),
- ( SubstBindingOfX = variable(Y, _) ->
- true
- ;
- \+ type_occurs(SubstBindingOfX, Y, !.Bindings),
- svmap.det_insert(Y, SubstBindingOfX, !Bindings)
- )
- )
- ;
- % Neither X nor Y is a head type param. X had not been bound yet.
- ( map.search(!.Bindings, Y, BindingOfY) ->
- apply_rec_subst_to_type(!.Bindings, BindingOfY, SubstBindingOfY),
- ( SubstBindingOfY = variable(X, _) ->
- true
- ;
- \+ type_occurs(SubstBindingOfY, X, !.Bindings),
- svmap.det_insert(X, SubstBindingOfY, !Bindings)
- )
- ;
- % Both X and Y are unbound type variables - bind one to the other.
- ( X = Y ->
- true
- ;
- svmap.det_insert(X, variable(Y, Kind), !Bindings)
- )
- )
- ).
-
-:- pred type_unify_head_type_param(tvar::in, tvar::in, kind::in,
- list(tvar)::in, tsubst::in, tsubst::out) is semidet.
-
-type_unify_head_type_param(Var, HeadVar, Kind, HeadTypeParams, !Bindings) :-
- ( map.search(!.Bindings, Var, BindingOfVar) ->
- BindingOfVar = variable(Var2, _),
- type_unify_head_type_param(Var2, HeadVar, Kind, HeadTypeParams,
- !Bindings)
- ;
- ( Var = HeadVar ->
- true
- ;
- \+ list.member(Var, HeadTypeParams),
- svmap.det_insert(Var, variable(HeadVar, Kind), !Bindings)
- )
- ).
-
- % Unify two types, neither of which are variables. Two special cases
- % which are not handled here are apply_n types and kinded types.
- % Those are handled below.
- %
-:- pred type_unify_nonvar(mer_type::in, mer_type::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-
-type_unify_nonvar(defined(SymName, ArgsX, _), defined(SymName, ArgsY, _),
- HeadTypeParams, !Bindings) :-
- % Instead of insisting that the names are equal and the arg lists
- % unify, we should consider attempting to expand equivalence types
- % first. That would require the type table to be passed in to the
- % unification algorithm, though.
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
-type_unify_nonvar(builtin(BuiltinType), builtin(BuiltinType), _, !Bindings).
-type_unify_nonvar(higher_order(ArgsX, no, Purity, EvalMethod),
- higher_order(ArgsY, no, Purity, EvalMethod),
- HeadTypeParams, !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
-type_unify_nonvar(higher_order(ArgsX, yes(RetX), Purity, EvalMethod),
- higher_order(ArgsY, yes(RetY), Purity, EvalMethod),
- HeadTypeParams, !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
- type_unify(RetX, RetY, HeadTypeParams, !Bindings).
-type_unify_nonvar(tuple(ArgsX, _), tuple(ArgsY, _), HeadTypeParams,
- !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
-
- % Handle apply_n types and kinded types.
- %
-:- pred type_unify_special(mer_type::in, mer_type::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-
-type_unify_special(X, Y, HeadTypeParams, !Bindings) :-
- ( X = apply_n(VarX, ArgsX, _) ->
- type_unify_apply(Y, VarX, ArgsX, HeadTypeParams, !Bindings)
- ; Y = apply_n(VarY, ArgsY, _) ->
- type_unify_apply(X, VarY, ArgsY, HeadTypeParams, !Bindings)
- ; X = kinded(RawX, _) ->
- ( Y = kinded(RawY, _) ->
- type_unify(RawX, RawY, HeadTypeParams, !Bindings)
- ;
- type_unify(RawX, Y, HeadTypeParams, !Bindings)
- )
- ; Y = kinded(RawY, _) ->
- type_unify(X, RawY, HeadTypeParams, !Bindings)
- ;
- fail
- ).
-
- % The idea here is that we try to strip off arguments from Y starting
- % from the end and unify each with the corresponding argument of X.
- % If we reach an atomic type before the arguments run out then we fail.
- % If we reach a variable before the arguments run out then we unify it
- % with what remains of the apply_n expression. If we manage to unify
- % all of the arguments then we unify the apply_n variable with what
- % remains of the other expression.
- %
- % Note that Y is not a variable, since that case would have been
- % caught by type_unify.
- %
-:- pred type_unify_apply(mer_type::in, tvar::in, list(mer_type)::in,
- list(tvar)::in, tsubst::in, tsubst::out) is semidet.
-
-type_unify_apply(defined(NameY, ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
- !Bindings) :-
- type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
- !Bindings),
- type_unify_var(VarX, defined(NameY, ArgsY, KindY), HeadTypeParams,
- !Bindings).
-type_unify_apply(Type @ builtin(_), VarX, [], HeadTypeParams, !Bindings) :-
- type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
-type_unify_apply(Type @ higher_order(_, _, _, _), VarX, [], HeadTypeParams,
- !Bindings) :-
- type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
-type_unify_apply(tuple(ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
- !Bindings) :-
- type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
- !Bindings),
- type_unify_var(VarX, tuple(ArgsY, KindY), HeadTypeParams, !Bindings).
-type_unify_apply(apply_n(VarY, ArgsY0, Kind0), VarX, ArgsX0, HeadTypeParams,
- !Bindings) :-
- list.length(ArgsX0, NArgsX0),
- list.length(ArgsY0, NArgsY0),
- compare(Result, NArgsX0, NArgsY0),
+maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId0, Arity,
+ MaybeTypes) :-
+ ( ConsId0 = cons(_SymName, _) ->
+ ConsId = ConsId0,
(
- Result = (<),
- type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
- HeadTypeParams, !Bindings),
- type_unify_var(VarX, apply_n(VarY, ArgsY, Kind),
- HeadTypeParams, !Bindings)
- ;
- Result = (=),
- % We know here that the list of remaining args will be empty.
- type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
- !Bindings),
- type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
- ;
- Result = (>),
- type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
- HeadTypeParams, !Bindings),
- type_unify_var(VarY, apply_n(VarX, ArgsX, Kind),
- HeadTypeParams, !Bindings)
- ).
-type_unify_apply(kinded(RawY, _), VarX, ArgsX, HeadTypeParams, !Bindings) :-
- type_unify_apply(RawY, VarX, ArgsX, HeadTypeParams, !Bindings).
+ MaybeType = yes(Type),
-:- pred type_unify_args(list(mer_type)::in, list(mer_type)::in,
- list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-
-type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
- !Bindings) :-
- list.reverse(ArgsX, RevArgsX),
- list.reverse(ArgsY0, RevArgsY0),
- type_unify_rev_args(RevArgsX, RevArgsY0, RevArgsY, KindY0, KindY,
- HeadTypeParams, !Bindings),
- list.reverse(RevArgsY, ArgsY).
-
-:- pred type_unify_rev_args(list(mer_type)::in, list(mer_type)::in,
- list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
-
-type_unify_rev_args([], ArgsY, ArgsY, KindY, KindY, _, !Bindings).
-type_unify_rev_args([ArgX | ArgsX], [ArgY0 | ArgsY0], ArgsY, KindY0, KindY,
- HeadTypeParams, !Bindings) :-
- type_unify(ArgX, ArgY0, HeadTypeParams, !Bindings),
- KindY1 = arrow(get_type_kind(ArgY0), KindY0),
- type_unify_rev_args(ArgsX, ArgsY0, ArgsY, KindY1, KindY,
- HeadTypeParams, !Bindings).
-
-type_unify_list([], [], _HeadTypeParams, !Bindings).
-type_unify_list([X | Xs], [Y | Ys], HeadTypeParams, !Bindings) :-
- type_unify(X, Y, HeadTypeParams, !Bindings),
- type_unify_list(Xs, Ys, HeadTypeParams, !Bindings).
-
- % type_occurs(Type, Var, Subst) succeeds iff Type contains Var,
- % perhaps indirectly via the substitution. (The variable must not
- % be mapped by the substitution.)
- %
-:- pred type_occurs(mer_type::in, tvar::in, tsubst::in) is semidet.
-
-type_occurs(variable(X, _), Y, Bindings) :-
- ( X = Y ->
- true
- ;
- map.search(Bindings, X, BindingOfX),
- type_occurs(BindingOfX, Y, Bindings)
- ).
-type_occurs(defined(_, Args, _), Y, Bindings) :-
- type_occurs_list(Args, Y, Bindings).
-type_occurs(higher_order(Args, MaybeRet, _, _), Y, Bindings) :-
- (
- type_occurs_list(Args, Y, Bindings)
- ;
- MaybeRet = yes(Ret),
- type_occurs(Ret, Y, Bindings)
- ).
-type_occurs(tuple(Args, _), Y, Bindings) :-
- type_occurs_list(Args, Y, Bindings).
-type_occurs(apply_n(X, Args, _), Y, Bindings) :-
- (
- X = Y
+ % XXX get_cons_id_non_existential_arg_types will fail
+ % for ConsIds with existentially typed arguments.
+ get_cons_id_non_existential_arg_types(ModuleInfo, Type,
+ ConsId, Types),
+ list__length(Types, Arity)
+ ->
+ MaybeTypes = list__map(func(T) = yes(T), Types)
;
- type_occurs_list(Args, Y, Bindings)
+ list__duplicate(Arity, no, MaybeTypes)
+ )
;
- map.search(Bindings, X, BindingOfX),
- type_occurs(BindingOfX, Y, Bindings)
+ MaybeTypes = []
).
-type_occurs(kinded(X, _), Y, Bindings) :-
- type_occurs(X, Y, Bindings).
-
-:- pred type_occurs_list(list(mer_type)::in, tvar::in, tsubst::in) is semidet.
-type_occurs_list([X | Xs], Y, Bindings) :-
+maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :-
(
- type_occurs(X, Y, Bindings)
+ MaybeType = yes(Type),
+ type_is_higher_order(Type, _, _, _, Types)
+ ->
+ MaybeTypes = list__map(func(T) = yes(T), Types)
;
- type_occurs_list(Xs, Y, Bindings)
+ list__duplicate(Arity, no, MaybeTypes)
).
%-----------------------------------------------------------------------------%
-apply_subst_to_type_map(Subst, !VarTypes) :-
- map__map_values(apply_subst_to_type_map_2(Subst), !VarTypes).
-
-:- pred apply_subst_to_type_map_2(tsubst::in, prog_var::in,
- mer_type::in, mer_type::out) is det.
-
-apply_subst_to_type_map_2(Subst, _, !Type) :-
- apply_subst_to_type(Subst, !Type).
+apply_variable_renaming_to_constraint(Renaming, !Constraint) :-
+ !.Constraint = constraint(Ids, ClassName, ClassArgTypes0),
+ apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0,
+ ClassArgTypes),
+ !:Constraint = constraint(Ids, ClassName, ClassArgTypes).
-apply_rec_subst_to_type_map(Subst, !VarTypes) :-
- map__map_values(apply_rec_subst_to_type_map_2(Subst), !VarTypes).
+apply_subst_to_constraint(Subst, !Constraint) :-
+ !.Constraint = constraint(Ids, ClassName, Types0),
+ apply_subst_to_type_list(Subst, Types0, Types),
+ !:Constraint = constraint(Ids, ClassName, Types).
-:- pred apply_rec_subst_to_type_map_2(tsubst::in, prog_var::in,
- mer_type::in, mer_type::out) is det.
+apply_rec_subst_to_constraint(Subst, !Constraint) :-
+ !.Constraint = constraint(Ids, Name, Types0),
+ apply_rec_subst_to_type_list(Subst, Types0, Types),
+ !:Constraint = constraint(Ids, Name, Types).
-apply_rec_subst_to_type_map_2(Subst, _, !Type) :-
- apply_rec_subst_to_type(Subst, !Type).
+%-----------------------------------------------------------------------------%
-apply_variable_renaming_to_type_map(Renaming, !Map) :-
- map__map_values(apply_variable_renaming_to_type_map_2(Renaming), !Map).
+apply_variable_renaming_to_constraint_list(Renaming, !Constraints) :-
+ list__map(apply_variable_renaming_to_constraint(Renaming), !Constraints).
-:- pred apply_variable_renaming_to_type_map_2(tvar_renaming::in, prog_var::in,
- mer_type::in, mer_type::out) is det.
+apply_subst_to_constraint_list(Subst, !Constraints) :-
+ list__map(apply_subst_to_constraint(Subst), !Constraints).
-apply_variable_renaming_to_type_map_2(Renaming, _, !Type) :-
- apply_variable_renaming_to_type(Renaming, !Type).
+apply_rec_subst_to_constraint_list(Subst, !Constraints) :-
+ list__map(apply_rec_subst_to_constraint(Subst), !Constraints).
%-----------------------------------------------------------------------------%
-apply_rec_subst_to_constraints(Subst, !Constraints) :-
+apply_variable_renaming_to_constraints(Renaming, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0),
- apply_rec_subst_to_constraint_list(Subst, Unproven0, Unproven),
- apply_rec_subst_to_constraint_list(Subst, Assumed0, Assumed),
+ apply_variable_renaming_to_constraint_list(Renaming, Unproven0, Unproven),
+ apply_variable_renaming_to_constraint_list(Renaming, Assumed0, Assumed),
Pred = (pred(_::in, C0::in, C::out) is det :-
- apply_rec_subst_to_constraint_list(Subst, C0, C)
+ apply_variable_renaming_to_constraint_list(Renaming, C0, C)
),
map.map_values(Pred, Redundant0, Redundant),
!:Constraints = constraints(Unproven, Assumed, Redundant).
-apply_rec_subst_to_constraint_list(Subst, !Constraints) :-
- list__map(apply_rec_subst_to_constraint(Subst), !Constraints).
-
-apply_rec_subst_to_constraint(Subst, !Constraint) :-
- !.Constraint = constraint(Ids, Name, Types0),
- apply_rec_subst_to_type_list(Subst, Types0, Types),
- !:Constraint = constraint(Ids, Name, Types).
-
apply_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0),
apply_subst_to_constraint_list(Subst, Unproven0, Unproven),
@@ -1584,13 +854,40 @@
map.map_values(Pred, Redundant0, Redundant),
!:Constraints = constraints(Unproven, Assumed, Redundant).
-apply_subst_to_constraint_list(Subst, Constraints0, Constraints) :-
- list__map(apply_subst_to_constraint(Subst), Constraints0, Constraints).
+apply_rec_subst_to_constraints(Subst, !Constraints) :-
+ !.Constraints = constraints(Unproven0, Assumed0, Redundant0),
+ apply_rec_subst_to_constraint_list(Subst, Unproven0, Unproven),
+ apply_rec_subst_to_constraint_list(Subst, Assumed0, Assumed),
+ Pred = (pred(_::in, C0::in, C::out) is det :-
+ apply_rec_subst_to_constraint_list(Subst, C0, C)
+ ),
+ map.map_values(Pred, Redundant0, Redundant),
+ !:Constraints = constraints(Unproven, Assumed, Redundant).
-apply_subst_to_constraint(Subst, Constraint0, Constraint) :-
- Constraint0 = constraint(Ids, ClassName, Types0),
- apply_subst_to_type_list(Subst, Types0, Types),
- Constraint = constraint(Ids, ClassName, Types).
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_constraint_proofs(Renaming, Proofs0, Proofs) :-
+ ( map__is_empty(Proofs0) ->
+ % Optimize the simple case.
+ Proofs = Proofs0
+ ;
+ map__keys(Proofs0, Keys0),
+ map__values(Proofs0, Values0),
+ apply_variable_renaming_to_prog_constraint_list(Renaming, Keys0, Keys),
+ list__map(rename_constraint_proof(Renaming), Values0, Values),
+ map__from_corresponding_lists(Keys, Values, Proofs)
+ ).
+
+ % Apply a type variable renaming to a class constraint proof.
+ %
+:- pred rename_constraint_proof(tvar_renaming::in, constraint_proof::in,
+ constraint_proof::out) is det.
+
+rename_constraint_proof(_TSubst, apply_instance(Num), apply_instance(Num)).
+rename_constraint_proof(TSubst, superclass(ClassConstraint0),
+ superclass(ClassConstraint)) :-
+ apply_variable_renaming_to_prog_constraint(TSubst, ClassConstraint0,
+ ClassConstraint).
apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
map__foldl(apply_subst_to_constraint_proofs_2(Subst), Proofs0,
@@ -1632,6 +929,18 @@
),
map__set(!.Map, Constraint, Proof, !:Map).
+%-----------------------------------------------------------------------------%
+
+apply_variable_renaming_to_constraint_map(Renaming, !ConstraintMap) :-
+ map__map_values(apply_variable_renaming_to_constraint_map_2(Renaming),
+ !ConstraintMap).
+
+:- pred apply_variable_renaming_to_constraint_map_2(tvar_renaming::in,
+ constraint_id::in, prog_constraint::in, prog_constraint::out) is det.
+
+apply_variable_renaming_to_constraint_map_2(Renaming, _Key, !Value) :-
+ apply_variable_renaming_to_prog_constraint(Renaming, !Value).
+
apply_subst_to_constraint_map(Subst, !ConstraintMap) :-
map__map_values(apply_subst_to_constraint_map_2(Subst), !ConstraintMap).
@@ -1650,152 +959,5 @@
apply_rec_subst_to_constraint_map_2(Subst, _Key, !Value) :-
apply_rec_subst_to_prog_constraint(Subst, !Value).
-
-apply_variable_renaming_to_constraints(Renaming, !Constraints) :-
- !.Constraints = constraints(Unproven0, Assumed0, Redundant0),
- apply_variable_renaming_to_constraint_list(Renaming, Unproven0, Unproven),
- apply_variable_renaming_to_constraint_list(Renaming, Assumed0, Assumed),
- Pred = (pred(_::in, C0::in, C::out) is det :-
- apply_variable_renaming_to_constraint_list(Renaming, C0, C)
- ),
- map.map_values(Pred, Redundant0, Redundant),
- !:Constraints = constraints(Unproven, Assumed, Redundant).
-
-apply_variable_renaming_to_constraint_list(Renaming, !Constraints) :-
- list__map(apply_variable_renaming_to_constraint(Renaming),
- !Constraints).
-
-apply_variable_renaming_to_constraint(Renaming, Constraint0, Constraint) :-
- Constraint0 = constraint(Ids, ClassName, ClassArgTypes0),
- apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0,
- ClassArgTypes),
- Constraint = constraint(Ids, ClassName, ClassArgTypes).
-
-apply_variable_renaming_to_constraint_proofs(Renaming, Proofs0, Proofs) :-
- ( map__is_empty(Proofs0) ->
- % Optimize the simple case.
- Proofs = Proofs0
- ;
- map__keys(Proofs0, Keys0),
- map__values(Proofs0, Values0),
- apply_variable_renaming_to_prog_constraint_list(Renaming, Keys0, Keys),
- list__map(rename_constraint_proof(Renaming), Values0, Values),
- map__from_corresponding_lists(Keys, Values, Proofs)
- ).
-
- % Apply a type variable renaming to a class constraint proof.
- %
-:- pred rename_constraint_proof(tvar_renaming::in, constraint_proof::in,
- constraint_proof::out) is det.
-
-rename_constraint_proof(_TSubst, apply_instance(Num), apply_instance(Num)).
-rename_constraint_proof(TSubst, superclass(ClassConstraint0),
- superclass(ClassConstraint)) :-
- apply_variable_renaming_to_prog_constraint(TSubst, ClassConstraint0,
- ClassConstraint).
-
-apply_variable_renaming_to_constraint_map(Renaming, !ConstraintMap) :-
- map__map_values(apply_variable_renaming_to_constraint_map_2(Renaming),
- !ConstraintMap).
-
-:- pred apply_variable_renaming_to_constraint_map_2(tvar_renaming::in,
- constraint_id::in, prog_constraint::in, prog_constraint::out) is det.
-
-apply_variable_renaming_to_constraint_map_2(Renaming, _Key, !Value) :-
- apply_variable_renaming_to_prog_constraint(Renaming, !Value).
-
-%-----------------------------------------------------------------------------%
-
-apply_partial_map_to_list([], _PartialMap, []).
-apply_partial_map_to_list([X | Xs], PartialMap, [Y | Ys]) :-
- ( map__search(PartialMap, X, Y0) ->
- Y = Y0
- ;
- Y = X
- ),
- apply_partial_map_to_list(Xs, PartialMap, Ys).
-
-%-----------------------------------------------------------------------------%
-
-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.
- ConsArity = cons_id_arity(ConsId),
- ( get_existq_cons_defn(ModuleInfo, Type, ConsId, ConsDefn) ->
- ConsDefn = ctor_defn(_TVarSet, ExistQTVars, _KindMap,
- 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
- ).
-
-%-----------------------------------------------------------------------------%
-
-maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId0, Arity,
- MaybeTypes) :-
- ( ConsId0 = cons(_SymName, _) ->
- ConsId = ConsId0,
- (
- MaybeType = yes(Type),
-
- % XXX get_cons_id_non_existential_arg_types will fail
- % for ConsIds with existentially typed arguments.
- get_cons_id_non_existential_arg_types(ModuleInfo, Type,
- ConsId, Types),
- list__length(Types, Arity)
- ->
- MaybeTypes = list__map(func(T) = yes(T), Types)
- ;
- list__duplicate(Arity, no, MaybeTypes)
- )
- ;
- MaybeTypes = []
- ).
-
-maybe_get_higher_order_arg_types(MaybeType, Arity, MaybeTypes) :-
- (
- MaybeType = yes(Type),
- type_is_higher_order(Type, _, _, _, Types)
- ->
- MaybeTypes = list__map(func(T) = yes(T), Types)
- ;
- list__duplicate(Arity, no, MaybeTypes)
- ).
-
-%-----------------------------------------------------------------------------%
-
-cell_cons_id(type_info_cell(Ctor)) = type_info_cell_constructor(Ctor).
-cell_cons_id(typeclass_info_cell) = typeclass_info_cell_constructor.
-
-cell_inst_cons_id(Which, Arity) = InstConsId :-
- % Neither of these function symbols exist, even with fake arity,
- % but they do not need to.
- (
- Which = type_info_cell(_),
- Symbol = "type_info"
- ;
- Which = typeclass_info_cell,
- Symbol = "typeclass_info"
- ),
- PrivateBuiltin = mercury_private_builtin_module,
- InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity).
-
-%-----------------------------------------------------------------------------%
-
-builtin_type_ctors_with_no_hlds_type_defn =
- [ qualified(mercury_public_builtin_module, "int") - 0,
- qualified(mercury_public_builtin_module, "string") - 0,
- qualified(mercury_public_builtin_module, "character") - 0,
- qualified(mercury_public_builtin_module, "float") - 0,
- qualified(mercury_public_builtin_module, "pred") - 0,
- qualified(mercury_public_builtin_module, "func") - 0,
- qualified(mercury_public_builtin_module, "void") - 0,
- qualified(mercury_public_builtin_module, "tuple") - 0
- ].
%-----------------------------------------------------------------------------%
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.383
diff -u -b -r1.383 typecheck.m
--- compiler/typecheck.m 28 Oct 2005 02:10:41 -0000 1.383
+++ compiler/typecheck.m 1 Nov 2005 14:22:48 -0000
@@ -81,13 +81,9 @@
:- interface.
:- import_module hlds.hlds_module.
-:- import_module hlds.hlds_pred.
-:- import_module mdbcomp.prim_data.
-:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module io.
-:- import_module list.
% typecheck(Module0, Module, FoundError, ExceededIterationLimit, !IO)
%
@@ -102,22 +98,6 @@
:- pred typecheck(module_info::in, module_info::out, bool::out, bool::out,
io::di, io::uo) is det.
- % Find a predicate which matches the given name and argument types.
- % Abort if there is no matching pred.
- % Abort if there are multiple matching preds.
- %
-:- pred typecheck__resolve_pred_overloading(module_info::in, pred_markers::in,
- list(mer_type)::in, tvarset::in, sym_name::in, sym_name::out, pred_id::out)
- is det.
-
- % Find a predicate or function from the list of pred_ids
- % which matches the given name and argument types.
- % Fail if there is no matching pred.
- % Abort if there are multiple matching preds.
- %
-:- pred typecheck__find_matching_pred_id(list(pred_id)::in, module_info::in,
- tvarset::in, list(mer_type)::in, pred_id::out, sym_name::out) is semidet.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -135,24 +115,29 @@
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_out.
+:- import_module hlds.hlds_pred.
:- import_module hlds.passes_aux.
:- import_module hlds.special_pred.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.modules.
+:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
:- import_module getopt_io.
:- import_module int.
+:- import_module list.
:- import_module map.
:- import_module multi_map.
:- import_module require.
@@ -270,18 +255,18 @@
% And this code also causes problems:
% if there are undefined modes,
% this code can end up calling error/1,
-% since post_typecheck__finish_ill_typed_pred
+% since post_finish_ill_typed_pred
% assumes that there are no undefined modes.
% %
% % if we get an error, we need to call
-% % post_typecheck__finish_ill_typed_pred on the
+% % post_finish_ill_typed_pred on the
% % pred, to ensure that its mode declaration gets
% % properly module qualified; then we call
% % `remove_predid', so that the predicate's definition
% % will be ignored by later passes (the declaration
% % will still be used to check any calls to it).
% %
-% post_typecheck__finish_ill_typed_pred(ModuleInfo0,
+% post_finish_ill_typed_pred(ModuleInfo0,
% PredId, PredInfo1, PredInfo),
% map__det_update(Preds0, PredId, PredInfo, Preds),
% *******************/
@@ -412,11 +397,7 @@
!IO),
Error = yes,
Changed = no
- ),
- % XXX rafe FIXME: Deleting this call to ignore causes the state
- % variable transformation to malfunction, leading to a bogus mode
- % error.
- ignore(!.ClausesInfo)
+ )
;
ClausesRep1IsEmpty = no,
pred_info_typevarset(!.PredInfo, TypeVarSet0),
@@ -480,10 +461,10 @@
ExplicitVarTypes1 = ExplicitVarTypes0
;
ExistQVars0 = [_ | _],
- apply_variable_renaming_to_type_map(ExistTypeRenaming,
+ apply_variable_renaming_to_vartypes(ExistTypeRenaming,
ExplicitVarTypes0, ExplicitVarTypes1)
),
- apply_variable_renaming_to_type_map(TVarRenaming,
+ apply_variable_renaming_to_vartypes(TVarRenaming,
ExplicitVarTypes1, ExplicitVarTypes),
clauses_info_set_explicit_vartypes(ExplicitVarTypes, !ClausesInfo),
@@ -597,10 +578,6 @@
)
).
-:- pred ignore(T::in) is det.
-
-ignore(_).
-
:- pred check_existq_clause(typecheck_info::in, tvarset::in, existq_tvars::in,
clause::in, io::di, io::uo) is det.
@@ -932,7 +909,7 @@
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
conj_list_to_goal(list__reverse(RevConj), GoalInfo, Goal),
- apply_partial_map_to_list(HeadVars0, Subst, HeadVars),
+ apply_partial_map_to_list(Subst, HeadVars0, HeadVars),
clauses_info_set_headvars(HeadVars, ClausesInfo0, ClausesInfo1),
SingleClause = clause(A, Goal, C, D),
@@ -1746,78 +1723,6 @@
%-----------------------------------------------------------------------------%
-typecheck__resolve_pred_overloading(ModuleInfo, CallerMarkers,
- ArgTypes, TVarSet, PredName0, PredName, PredId) :-
- % Note: calls to preds declared in `.opt' files should always be
- % module qualified, so they should not be considered
- % when resolving overloading.
-
- module_info_get_predicate_table(ModuleInfo, PredTable),
- (
- predicate_table_search_pred_sym(PredTable,
- calls_are_fully_qualified(CallerMarkers), PredName0, PredIds0)
- ->
- PredIds = PredIds0
- ;
- PredIds = []
- ),
-
- % Check if there any of the candidate pred_ids have argument/return types
- % which subsume the actual argument/return types of this function call.
- (
- typecheck__find_matching_pred_id(PredIds, ModuleInfo,
- TVarSet, ArgTypes, PredId1, PredName1)
- ->
- PredId = PredId1,
- PredName = PredName1
- ;
- % If there is no matching predicate for this call,
- % then this predicate must have a type error which
- % should have been caught by typechecking.
- unexpected(this_file, "type error in pred call: no matching pred")
- ).
-
-typecheck__find_matching_pred_id([PredId | PredIds], ModuleInfo,
- TVarSet, ArgTypes, ThePredId, PredName) :-
- (
- % Lookup the argument types of the candidate predicate
- % (or the argument types + return type of the candidate function).
- %
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- pred_info_arg_types(PredInfo, PredTVarSet, PredExistQVars0,
- PredArgTypes0),
- pred_info_tvar_kinds(PredInfo, PredKindMap),
-
- arg_type_list_subsumes(TVarSet, ArgTypes, PredTVarSet, PredKindMap,
- PredExistQVars0, PredArgTypes0)
- ->
- % We've found a matching predicate.
- % Was there was more than one matching predicate/function?
-
- PName = pred_info_name(PredInfo),
- Module = pred_info_module(PredInfo),
- PredName = qualified(Module, PName),
- (
- typecheck__find_matching_pred_id(PredIds,
- ModuleInfo, TVarSet, ArgTypes, _OtherPredId, _)
- ->
- % XXX this should report an error properly, not
- % via error/1
- unexpected(this_file, "Type error in predicate call: " ++
- "unresolvable predicate overloading. " ++
- "You need to use an explicit " ++
- "module qualifier. " ++
- "Compile with -V to find out where.")
- ;
- ThePredId = PredId
- )
- ;
- typecheck__find_matching_pred_id(PredIds, ModuleInfo,
- TVarSet, ArgTypes, ThePredId, PredName)
- ).
-
-%-----------------------------------------------------------------------------%
-
% Rename apart the type variables in called predicate's arg types
% separately for each type assignment, resulting in an "arg type
% assignment set", and then for each arg type assignment in the
@@ -2985,7 +2890,7 @@
%-----------------------------------------------------------------------------%
% Note: changes here may require changes to
- % post_typecheck__resolve_unify_functor,
+ % post_resolve_unify_functor,
% intermod__module_qualify_unify_rhs,
% recompilation__usage__find_matching_constructors
% and recompilation__check__check_functor_ambiguities.
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.10
diff -u -b -r1.10 typecheck_errors.m
--- compiler/typecheck_errors.m 28 Oct 2005 02:10:41 -0000 1.10
+++ compiler/typecheck_errors.m 1 Nov 2005 04:46:02 -0000
@@ -113,6 +113,7 @@
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
Index: compiler/typecheck_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_info.m,v
retrieving revision 1.5
diff -u -b -r1.5 typecheck_info.m
--- compiler/typecheck_info.m 28 Oct 2005 02:10:41 -0000 1.5
+++ compiler/typecheck_info.m 1 Nov 2005 04:46:38 -0000
@@ -303,6 +303,7 @@
:- import_module libs.compiler_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module map.
Index: compiler/typeclasses.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typeclasses.m,v
retrieving revision 1.6
diff -u -b -r1.6 typeclasses.m
--- compiler/typeclasses.m 24 Oct 2005 04:14:33 -0000 1.6
+++ compiler/typeclasses.m 1 Nov 2005 04:46:45 -0000
@@ -93,6 +93,7 @@
:- import_module check_hlds.typecheck_errors.
:- import_module hlds.hlds_module.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module bool.
:- import_module int.
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.155
diff -u -b -r1.155 unify_proc.m
--- compiler/unify_proc.m 28 Oct 2005 02:10:42 -0000 1.155
+++ compiler/unify_proc.m 1 Nov 2005 13:33:48 -0000
@@ -71,9 +71,8 @@
% Add a new request for a unification procedure to the proc_requests table.
%
-:- pred request_unify(unify_proc_id::in, inst_varset::in,
- determinism::in, prog_context::in, module_info::in, module_info::out)
- is det.
+:- pred request_unify(unify_proc_id::in, inst_varset::in, determinism::in,
+ prog_context::in, module_info::in, module_info::out) is det.
% Add a new request for a procedure (not necessarily a unification)
% to the request queue. Return the procedure's newly allocated proc_id.
@@ -794,50 +793,50 @@
% can_generate_special_pred_clauses_for_type ensures the unexpected
% cases can never occur.
(
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
Name = "builtin_unify_int"
;
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
Name = "builtin_unify_character"
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
Name = "builtin_unify_string"
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
Name = "builtin_unify_float"
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
Name = "builtin_unify_pred"
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
unexpected(this_file, "generate_builtin_unify: tuple")
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
unexpected(this_file, "generate_builtin_unify: enum")
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
unexpected(this_file, "generate_builtin_unify: enum")
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
unexpected(this_file, "generate_builtin_unify: variable type")
;
- TypeCategory = type_info_type,
+ TypeCategory = type_cat_type_info,
unexpected(this_file, "generate_builtin_unify: type_info type")
;
- TypeCategory = type_ctor_info_type,
+ TypeCategory = type_cat_type_ctor_info,
unexpected(this_file, "generate_builtin_unify: type_ctor_info type")
;
- TypeCategory = typeclass_info_type,
+ TypeCategory = type_cat_typeclass_info,
unexpected(this_file, "generate_builtin_unify: typeclass_info type")
;
- TypeCategory = base_typeclass_info_type,
+ TypeCategory = type_cat_base_typeclass_info,
unexpected(this_file,
"generate_builtin_unify: base_typeclass_info type")
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
unexpected(this_file, "generate_builtin_unify: void type")
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
unexpected(this_file, "generate_builtin_unify: user_ctor type")
),
build_call(Name, ArgVars, Context, UnifyGoal, !Info),
@@ -1073,50 +1072,50 @@
% can_generate_special_pred_clauses_for_type ensures the unexpected
% cases can never occur.
(
- TypeCategory = int_type,
+ TypeCategory = type_cat_int,
Name = "builtin_compare_int"
;
- TypeCategory = char_type,
+ TypeCategory = type_cat_char,
Name = "builtin_compare_character"
;
- TypeCategory = str_type,
+ TypeCategory = type_cat_string,
Name = "builtin_compare_string"
;
- TypeCategory = float_type,
+ TypeCategory = type_cat_float,
Name = "builtin_compare_float"
;
- TypeCategory = higher_order_type,
+ TypeCategory = type_cat_higher_order,
Name = "builtin_compare_pred"
;
- TypeCategory = tuple_type,
+ TypeCategory = type_cat_tuple,
unexpected(this_file, "generate_builtin_compare: tuple type")
;
- TypeCategory = enum_type,
+ TypeCategory = type_cat_enum,
unexpected(this_file, "generate_builtin_compare: enum type")
;
- TypeCategory = dummy_type,
+ TypeCategory = type_cat_dummy,
unexpected(this_file, "generate_builtin_compare: dummy type")
;
- TypeCategory = variable_type,
+ TypeCategory = type_cat_variable,
unexpected(this_file, "generate_builtin_compare: variable type")
;
- TypeCategory = type_info_type,
+ TypeCategory = type_cat_type_info,
unexpected(this_file, "generate_builtin_compare: type_info type")
;
- TypeCategory = type_ctor_info_type,
+ TypeCategory = type_cat_type_ctor_info,
unexpected(this_file, "generate_builtin_compare: type_ctor_info type")
;
- TypeCategory = typeclass_info_type,
+ TypeCategory = type_cat_typeclass_info,
unexpected(this_file, "generate_builtin_compare: typeclass_info type")
;
- TypeCategory = base_typeclass_info_type,
+ TypeCategory = type_cat_base_typeclass_info,
unexpected(this_file,
"generate_builtin_compare: base_typeclass_info type")
;
- TypeCategory = void_type,
+ TypeCategory = type_cat_void,
unexpected(this_file, "generate_builtin_compare: void type")
;
- TypeCategory = user_ctor_type,
+ TypeCategory = type_cat_user_ctor,
unexpected(this_file, "generate_builtin_compare: user_ctor type")
),
build_call(Name, ArgVars, Context, CompareGoal, !Info),
@@ -1143,8 +1142,7 @@
%
PredId = invalid_pred_id,
ModeId = invalid_proc_id,
- Call = call(PredId, ModeId, ArgVars, not_builtin,
- no, ComparePredName),
+ Call = call(PredId, ModeId, ArgVars, not_builtin, no, ComparePredName),
goal_info_init(Context, GoalInfo),
Goal = Call - GoalInfo
;
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.30
diff -u -b -r1.30 var_locn.m
--- compiler/var_locn.m 28 Oct 2005 02:10:43 -0000 1.30
+++ compiler/var_locn.m 1 Nov 2005 04:01:43 -0000
@@ -25,7 +25,6 @@
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
-:- import_module hlds.hlds_pred.
:- import_module ll_backend.global_data.
:- import_module ll_backend.llds.
:- import_module libs.options.
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.107
diff -u -b -r1.107 compiler_design.html
--- compiler/notes/compiler_design.html 28 Oct 2005 02:10:59 -0000 1.107
+++ compiler/notes/compiler_design.html 1 Nov 2005 09:11:14 -0000
@@ -278,7 +278,8 @@
for printing the parse tree. prog_util.m contains some utility
predicates for manipulating the parse tree, prog_mode contains utility
predicates for manipulating insts and modes, prog_type contains utility
- predicates for manipulating types, prog_foreign contains utility
+ predicates for manipulating types, prog_type_subst contains predicates
+ for performing substitutions on types, prog_foreign contains utility
predicates for manipulating foreign code, prog_mutable contains utility
predicates for manipulating mutable variables,
while error_util.m contains predicates
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list