[m-rev.] for review: add `any_is_bound' pragma
David Overton
dmo at cs.mu.OZ.AU
Thu Jul 24 11:56:24 AEST 2003
On Thu, Jul 17, 2003 at 11:39:49PM +1000, Fergus Henderson wrote:
> Compiler options that affect the language semantics should be avoided
> where possible. I would rather make --default-any-is-bound be the
> default, and then there's no need for the compiler option or the
> `any_is_bound' pragma.
>
> As for the `any_is_not_bound' pragma, well, I don't really like the name.
> Also, I'd rather explicit syntax as part of the type declaration,
> rather than a separate pragma. For example, perhaps something along
> the lines of `:- solver type ...' instead of `:- type ...'.
Here's a new full diff using the `:- solver type' syntax instead of
pragmas.
Estimated hours taken: 120
Branches: main
Allow types to be declared as "solver" types using the syntax
`:- solver type ...'.
For a non-solver type t (i.e. any type declared without using the
`solver' keyword), the inst `any' should be considered to be equivalent
to a bound inst i where i contains all the functors of the type t and
each argument has inst `any'. For solver types, `any' retains its
previous meaning.
This is required to allow us to represent HAL's `old' inst using `any'.
In HAL, `old' is like `any' if the type is an instance of a particular
type class (`solver/1'). However, for types that are not instances of
`solver/1', `old' needs to be treated as though it is `bound'.
library/ops.m:
Add `solver' as a unary prefix operator.
compiler/prog_data.m:
Add a field to the type `type_defn' to record whether or not the
type is a solver type.
compiler/hlds_data.m:
Add an equivalent field to the type `hlds_type_body'.
compiler/prog_io.m:
compiler/make_hlds.m:
compiler/modules.m:
compiler/mercury_to_mercury.m:
compiler/hlds_out.m:
Handle the new ":- solver type ..." syntax.
compiler/det_report.m:
compiler/equiv_type.m:
compiler/foreign.m:
compiler/hlds_code_util.m:
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic_util.m:
compiler/ml_code_gen.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds.m:
compiler/module_qual.m:
compiler/post_typecheck.m:
compiler/pragma_c_gen.m:
compiler/recompilation.check.m:
compiler/recompilation.usage.m:
compiler/recompilation.version.m:
compiler/special_pred.m:
compiler/stack_opt.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_gen.m:
compiler/unify_proc.m:
Handle the changes to `type_defn' and `hlds_type_body'.
compiler/type_util.m:
Add predicates `type_util__is_solver_type' and
`type_body_is_solver_type'.
compiler/inst_match.m:
compiler/inst_util.m:
In inst_matches_{initial,final,binding} and
abstractly_unify_inst_functor, when we are comparing `any' insts, check
whether or not the type is a solver type and treat it appropriately.
compiler/instmap.m:
compiler/modecheck_unify.m:
Pass type information to abstractly_unify_inst_functor.
compiler/mode_util.m:
Add a predicate `constructors_to_bound_any_insts' which is the same as
`constructors_to_bound_insts' except that it makes the arguments of the
bound inst `any' instead of `ground'.
tests/invalid/any_mode.m:
tests/invalid/any_mode.err_exp:
Modify this test case to use a "solver" type instead of `int'.
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.81
diff -u -r1.81 det_report.m
--- compiler/det_report.m 27 May 2003 05:57:08 -0000 1.81
+++ compiler/det_report.m 22 Jul 2003 07:05:54 -0000
@@ -575,7 +575,7 @@
{ det_lookup_var_type(ModuleInfo, ProcInfo, Var,
TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _, _, _) }
+ { ConsTable = TypeBody ^ du_type_cons_tag_values }
->
{ map__keys(ConsTable, ConsIds) },
{ det_diagnose_missing_consids(ConsIds, Cases,
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.32
diff -u -r1.32 equiv_type.m
--- compiler/equiv_type.m 15 Mar 2003 03:08:45 -0000 1.32
+++ compiler/equiv_type.m 22 Jul 2003 07:05:54 -0000
@@ -348,8 +348,8 @@
equiv_type__replace_in_type_2(TBody0, VarSet0, EqvMap, [TypeCtor],
TBody, VarSet, ContainsCirc, Info0, Info).
-equiv_type__replace_in_type_defn(_, du_type(TBody0,
- EqPred), VarSet0, EqvMap, du_type(TBody, EqPred),
+equiv_type__replace_in_type_defn(_, du_type(TBody0, IsSolverType, EqPred),
+ VarSet0, EqvMap, du_type(TBody, IsSolverType, EqPred),
VarSet, no, Info0, Info) :-
equiv_type__replace_in_du(TBody0, VarSet0, EqvMap, TBody,
VarSet, Info0, Info).
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.28
diff -u -r1.28 foreign.m
--- compiler/foreign.m 26 May 2003 08:59:54 -0000 1.28
+++ compiler/foreign.m 22 Jul 2003 07:05:54 -0000
@@ -670,7 +670,7 @@
map__search(Types, TypeCtor, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(ForeignTypeBody) ->
+ ( Body = foreign_type(ForeignTypeBody, _IsSolverType) ->
ExportType = foreign(fst(
foreign_type_body_to_exported_type(ModuleInfo,
ForeignTypeBody)))
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.7
diff -u -r1.7 hlds_code_util.m
--- compiler/hlds_code_util.m 24 Jun 2003 14:20:48 -0000 1.7
+++ compiler/hlds_code_util.m 22 Jul 2003 07:05:54 -0000
@@ -92,7 +92,7 @@
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(_, ConsTable0, _, _, _, _)
+ ConsTable0 = TypeBody ^ du_type_cons_tag_values
->
ConsTable = ConsTable0
;
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.78
diff -u -r1.78 hlds_data.m
--- compiler/hlds_data.m 24 Jun 2003 14:20:48 -0000 1.78
+++ compiler/hlds_data.m 22 Jul 2003 07:05:54 -0000
@@ -327,13 +327,17 @@
% pragma for this type?
du_type_reserved_tag :: bool,
+ % should the `any' inst be considered
+ % `bound' for this type?
+ du_type_is_solver_type :: is_solver_type,
+
% are there `:- pragma foreign' type
% declarations for this type?
du_type_is_foreign_type :: maybe(foreign_type_body)
)
; eqv_type(type)
- ; foreign_type(foreign_type_body)
- ; abstract_type.
+ ; foreign_type(foreign_type_body, is_solver_type)
+ ; abstract_type(is_solver_type).
:- type foreign_type_body
---> foreign_type_body(
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.313
diff -u -r1.313 hlds_out.m
--- compiler/hlds_out.m 24 Jun 2003 14:20:48 -0000 1.313
+++ compiler/hlds_out.m 22 Jul 2003 07:05:54 -0000
@@ -2922,7 +2922,16 @@
),
hlds_out__write_indent(Indent),
- io__write_string(":- type "),
+ (
+ { TypeBody ^ du_type_is_solver_type = solver_type
+ ; TypeBody = abstract_type(solver_type)
+ ; TypeBody = foreign_type(_, solver_type)
+ }
+ ->
+ io__write_string(":- solver type ")
+ ;
+ io__write_string(":- type ")
+ ),
hlds_out__write_type_name(TypeCtor),
hlds_out__write_type_params(TVarSet, TypeParams),
{ Indent1 = Indent + 1 },
@@ -2967,7 +2976,7 @@
:- mode hlds_out__write_type_body(in, in, in, di, uo) is det.
hlds_out__write_type_body(Indent, Tvarset, du_type(Ctors, Tags, Enum,
- MaybeEqualityPred, ReservedTag, Foreign)) -->
+ MaybeEqualityPred, ReservedTag, _IsSolverType, Foreign)) -->
io__write_string(" --->\n"),
( { Enum = yes } ->
hlds_out__write_indent(Indent),
@@ -3020,10 +3029,10 @@
term_io__write_term(Tvarset, Type),
io__write_string(".\n").
-hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
+hlds_out__write_type_body(_Indent, _Tvarset, abstract_type(_IsSolverType)) -->
io__write_string(".\n").
-hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_)) -->
+hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _)) -->
% XXX
io__write_string(" == $foreign_type.\n").
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.53
diff -u -r1.53 inst_match.m
--- compiler/inst_match.m 2 Jun 2003 04:56:28 -0000 1.53
+++ compiler/inst_match.m 22 Jul 2003 07:05:54 -0000
@@ -436,6 +436,12 @@
I ^ any_matches_any = yes,
compare_uniqueness(I ^ uniqueness_comparison, UniqA, UniqB).
inst_matches_initial_4(any(_), free, _, I, I).
+inst_matches_initial_4(any(UniqA), ground(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_initial_2(InstA, InstB, Type, Info0, Info).
+inst_matches_initial_4(any(UniqA), bound(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_initial_2(InstA, InstB, Type, Info0, Info).
inst_matches_initial_4(free, any(_), _, I, I).
inst_matches_initial_4(free, free, _, I, I).
inst_matches_initial_4(bound(UniqA, ListA), any(UniqB), _, Info, Info) :-
@@ -447,10 +453,10 @@
Info0, Info) :-
compare_uniqueness(Info0 ^ uniqueness_comparison, UniqA, UniqB),
bound_inst_list_matches_initial(ListA, ListB, Type, Info0, Info).
-inst_matches_initial_4(bound(UniqA, ListA), ground(UniqB, none), _,
+inst_matches_initial_4(bound(UniqA, ListA), ground(UniqB, none), Type,
Info, Info) :-
compare_uniqueness(Info ^ uniqueness_comparison, UniqA, UniqB),
- bound_inst_list_is_ground(ListA, Info^module_info),
+ bound_inst_list_is_ground(ListA, Type, Info^module_info),
compare_bound_inst_list_uniq(Info ^ uniqueness_comparison,
ListA, UniqB, Info^module_info).
inst_matches_initial_4(bound(Uniq, List), abstract_inst(_,_), _, Info, Info) :-
@@ -903,6 +909,12 @@
inst_matches_final_3(any(UniqA), any(UniqB), _, I, I) :-
unique_matches_final(UniqA, UniqB).
+inst_matches_final_3(any(UniqA), ground(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_final_2(InstA, InstB, Type, Info0, Info).
+inst_matches_final_3(any(UniqA), bound(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_final_2(InstA, InstB, Type, Info0, Info).
inst_matches_final_3(free, any(Uniq), _, I, I) :-
% We do not yet allow `free' to match `any',
% unless the `any' is `clobbered_any' or `mostly_clobbered_any'.
@@ -921,10 +933,10 @@
Info0, Info) :-
unique_matches_final(UniqA, UniqB),
bound_inst_list_matches_final(ListA, ListB, MaybeType, Info0, Info).
-inst_matches_final_3(bound(UniqA, ListA), ground(UniqB, none), _,
+inst_matches_final_3(bound(UniqA, ListA), ground(UniqB, none), Type,
Info, Info) :-
unique_matches_final(UniqA, UniqB),
- bound_inst_list_is_ground(ListA, Info^module_info),
+ bound_inst_list_is_ground(ListA, Type, Info^module_info),
bound_inst_list_matches_uniq(ListA, UniqB, Info^module_info).
inst_matches_final_3(ground(UniqA, GroundInstInfoA), any(UniqB), _,
Info, Info) :-
@@ -936,7 +948,7 @@
\+ ground_inst_info_is_nonstandard_func_mode(GroundInstInfoA,
Info^module_info),
unique_matches_final(UniqA, UniqB),
- bound_inst_list_is_ground(ListB, Info^module_info),
+ bound_inst_list_is_ground(ListB, MaybeType, Info^module_info),
uniq_matches_bound_inst_list(UniqA, ListB, Info^module_info),
(
MaybeType = yes(Type),
@@ -1070,19 +1082,37 @@
:- mode inst_matches_binding_3(in, in, in, in, out) is semidet.
% Note that `any' is *not* considered to match `any' unless
-% Info ^ any_matches_any = yes.
+% Info ^ any_matches_any = yes or the type is a solver type.
inst_matches_binding_3(free, free, _, I, I).
-inst_matches_binding_3(any(_), any(_), _, I, I) :-
- I ^ any_matches_any = yes.
+inst_matches_binding_3(any(UniqA), any(UniqB), Type, Info0, Info) :-
+ ( Info0 ^ any_matches_any = yes ->
+ Info = Info0
+ ;
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqB, InstB),
+ inst_matches_binding_2(InstA, InstB, Type, Info0, Info)
+ ).
+inst_matches_binding_3(any(UniqA), ground(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_binding_2(InstA, InstB, Type, Info0, Info).
+inst_matches_binding_3(any(UniqA), bound(_, _)@InstB, Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqA, InstA),
+ inst_matches_binding_2(InstA, InstB, Type, Info0, Info).
+inst_matches_binding_3(ground(_, _)@InstA, any(UniqB), Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqB, InstB),
+ inst_matches_binding_2(InstA, InstB, Type, Info0, Info).
+inst_matches_binding_3(bound(_, _)@InstA, any(UniqB), Type, Info0, Info) :-
+ maybe_any_to_bound(Type, Info0 ^ module_info, UniqB, InstB),
+ inst_matches_binding_2(InstA, InstB, Type, Info0, Info).
inst_matches_binding_3(bound(_UniqA, ListA), bound(_UniqB, ListB), MaybeType,
Info0, Info) :-
bound_inst_list_matches_binding(ListA, ListB, MaybeType, Info0, Info).
-inst_matches_binding_3(bound(_UniqA, ListA), ground(_UniqB, none), _,
+inst_matches_binding_3(bound(_UniqA, ListA), ground(_UniqB, none), Type,
Info, Info) :-
- bound_inst_list_is_ground(ListA, Info^module_info).
+ bound_inst_list_is_ground(ListA, Type, Info^module_info).
inst_matches_binding_3(ground(_UniqA, _), bound(_UniqB, ListB), MaybeType,
Info, Info) :-
- bound_inst_list_is_ground(ListB, Info^module_info),
+ bound_inst_list_is_ground(ListB, MaybeType, Info^module_info),
(
MaybeType = yes(Type),
% We can only do this check if the type is known.
@@ -1236,35 +1266,54 @@
% or the equivalent. Abstract insts are not considered ground.
inst_is_ground(ModuleInfo, Inst) :-
+ inst_is_ground(ModuleInfo, no, Inst).
+
+:- pred inst_is_ground(module_info, maybe(type), inst).
+:- mode inst_is_ground(in, in, in) is semidet.
+
+inst_is_ground(ModuleInfo, MaybeType, Inst) :-
set__init(Expansions0),
- inst_is_ground_2(ModuleInfo, Inst, Expansions0, _Expansions).
+ inst_is_ground_1(ModuleInfo, MaybeType, Inst, Expansions0, _Expansions).
% The third arg is the set of insts which have already
% been expanded - we use this to avoid going into an
% infinite loop.
-:- pred inst_is_ground_2(module_info, inst, set(inst), set(inst)).
-:- mode inst_is_ground_2(in, in, in, out) is semidet.
+:- pred inst_is_ground_1(module_info, maybe(type), inst, set(inst), set(inst)).
+:- mode inst_is_ground_1(in, in, in, in, out) is semidet.
-inst_is_ground_2(_, not_reached, Expansions, Expansions).
-inst_is_ground_2(ModuleInfo, bound(_, List), Expansions0, Expansions) :-
- bound_inst_list_is_ground_2(List, ModuleInfo, Expansions0, Expansions).
-inst_is_ground_2(_, ground(_, _), Expansions, Expansions).
-inst_is_ground_2(_, inst_var(_), Expansions, Expansions) :-
- error("internal error: uninstantiated inst parameter").
-inst_is_ground_2(ModuleInfo, Inst, Expansions0, Expansions) :-
- Inst = constrained_inst_vars(_, Inst2),
- inst_is_ground_2(ModuleInfo, Inst2, Expansions0, Expansions).
-inst_is_ground_2(ModuleInfo, Inst, Expansions0, Expansions) :-
- Inst = defined_inst(InstName),
+inst_is_ground_1(ModuleInfo, MaybeType, Inst, Expansions0, Expansions) :-
( set__member(Inst, Expansions0) ->
Expansions = Expansions0
;
set__insert(Expansions0, Inst, Expansions1),
- inst_lookup(ModuleInfo, InstName, Inst2),
- inst_is_ground_2(ModuleInfo, Inst2, Expansions1, Expansions)
+ inst_is_ground_2(ModuleInfo, MaybeType, Inst,
+ Expansions1, Expansions)
).
+:- pred inst_is_ground_2(module_info, maybe(type), inst, set(inst), set(inst)).
+:- mode inst_is_ground_2(in, in, in, in, out) is semidet.
+
+inst_is_ground_2(_, _, not_reached, Expansions, Expansions).
+inst_is_ground_2(ModuleInfo, MaybeType, bound(_, List),
+ Expansions0, Expansions) :-
+ bound_inst_list_is_ground_2(List, MaybeType,
+ ModuleInfo, Expansions0, Expansions).
+inst_is_ground_2(_, _, ground(_, _), Expansions, Expansions).
+inst_is_ground_2(_, _, inst_var(_), Expansions, Expansions) :-
+ error("internal error: uninstantiated inst parameter").
+inst_is_ground_2(ModuleInfo, MaybeType, Inst, Expansions0, Expansions) :-
+ Inst = constrained_inst_vars(_, Inst2),
+ inst_is_ground_1(ModuleInfo, MaybeType, Inst2, Expansions0, Expansions).
+inst_is_ground_2(ModuleInfo, MaybeType, Inst, Expansions0, Expansions) :-
+ Inst = defined_inst(InstName),
+ inst_lookup(ModuleInfo, InstName, Inst2),
+ inst_is_ground_1(ModuleInfo, MaybeType, Inst2, Expansions0, Expansions).
+inst_is_ground_2(ModuleInfo, MaybeType, any(Uniq), Expansions0, Expansions) :-
+ maybe_any_to_bound(MaybeType, ModuleInfo, Uniq, Inst),
+ inst_is_ground_1(ModuleInfo, MaybeType, Inst, Expansions0, Expansions).
+
+
% inst_is_ground_or_any succeeds iff the inst passed is `ground',
% `any', or the equivalent. Fails for abstract insts.
@@ -1467,10 +1516,20 @@
%-----------------------------------------------------------------------------%
-bound_inst_list_is_ground([], _).
-bound_inst_list_is_ground([functor(_Name, Args)|BoundInsts], ModuleInfo) :-
- inst_list_is_ground(Args, ModuleInfo),
- bound_inst_list_is_ground(BoundInsts, ModuleInfo).
+bound_inst_list_is_ground(BoundInsts, ModuleInfo) :-
+ bound_inst_list_is_ground(BoundInsts, no, ModuleInfo).
+
+:- pred bound_inst_list_is_ground(list(bound_inst), maybe(type), module_info).
+:- mode bound_inst_list_is_ground(in, in, in) is semidet.
+
+bound_inst_list_is_ground([], _, _).
+bound_inst_list_is_ground([functor(Name, Args)|BoundInsts], MaybeType,
+ ModuleInfo) :-
+ maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, Name,
+ list__length(Args), MaybeTypes),
+ inst_list_is_ground(Args, MaybeTypes, ModuleInfo),
+ bound_inst_list_is_ground(BoundInsts, MaybeType, ModuleInfo).
+
bound_inst_list_is_ground_or_any([], _).
bound_inst_list_is_ground_or_any([functor(_Name, Args)|BoundInsts],
@@ -1503,15 +1562,18 @@
%-----------------------------------------------------------------------------%
-:- pred bound_inst_list_is_ground_2(list(bound_inst), module_info,
+:- pred bound_inst_list_is_ground_2(list(bound_inst), maybe(type), module_info,
set(inst), set(inst)).
-:- mode bound_inst_list_is_ground_2(in, in, in, out) is semidet.
+:- mode bound_inst_list_is_ground_2(in, in, in, in, out) is semidet.
-bound_inst_list_is_ground_2([], _, Expansions, Expansions).
-bound_inst_list_is_ground_2([functor(_Name, Args)|BoundInsts], ModuleInfo,
- Expansions0, Expansions) :-
- inst_list_is_ground_2(Args, ModuleInfo, Expansions0, Expansions1),
- bound_inst_list_is_ground_2(BoundInsts, ModuleInfo,
+bound_inst_list_is_ground_2([], _, _, Expansions, Expansions).
+bound_inst_list_is_ground_2([functor(Name, Args)|BoundInsts], MaybeType,
+ ModuleInfo, Expansions0, Expansions) :-
+ maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, Name,
+ list__length(Args), MaybeTypes),
+ inst_list_is_ground_2(Args, MaybeTypes, ModuleInfo,
+ Expansions0, Expansions1),
+ bound_inst_list_is_ground_2(BoundInsts, MaybeType, ModuleInfo,
Expansions1, Expansions).
:- pred bound_inst_list_is_ground_or_any_2(list(bound_inst), module_info,
@@ -1575,10 +1637,17 @@
%-----------------------------------------------------------------------------%
-inst_list_is_ground([], _).
-inst_list_is_ground([Inst | Insts], ModuleInfo) :-
- inst_is_ground(ModuleInfo, Inst),
- inst_list_is_ground(Insts, ModuleInfo).
+inst_list_is_ground(Insts, ModuleInfo) :-
+ MaybeTypes = list__duplicate(list__length(Insts), no),
+ inst_list_is_ground(Insts, MaybeTypes, ModuleInfo).
+
+:- pred inst_list_is_ground(list(inst), list(maybe(type)), module_info).
+:- mode inst_list_is_ground(in, in, in) is semidet.
+
+inst_list_is_ground([], [], _).
+inst_list_is_ground([Inst | Insts], [MaybeType | MaybeTypes], ModuleInfo) :-
+ inst_is_ground(ModuleInfo, MaybeType, Inst),
+ inst_list_is_ground(Insts, MaybeTypes, ModuleInfo).
inst_list_is_ground_or_any([], _).
inst_list_is_ground_or_any([Inst | Insts], ModuleInfo) :-
@@ -1607,13 +1676,16 @@
%-----------------------------------------------------------------------------%
-:- pred inst_list_is_ground_2(list(inst), module_info, set(inst), set(inst)).
-:- mode inst_list_is_ground_2(in, in, in, out) is semidet.
-
-inst_list_is_ground_2([], _, Expansions, Expansions).
-inst_list_is_ground_2([Inst | Insts], ModuleInfo, Expansions0, Expansions) :-
- inst_is_ground_2(ModuleInfo, Inst, Expansions0, Expansions1),
- inst_list_is_ground_2(Insts, ModuleInfo, Expansions1, Expansions).
+:- pred inst_list_is_ground_2(list(inst), list(maybe(type)),
+ module_info, set(inst), set(inst)).
+:- mode inst_list_is_ground_2(in, in, in, in, out) is semidet.
+
+inst_list_is_ground_2([], _, _, Expansions, Expansions).
+inst_list_is_ground_2([Inst | Insts], [MaybeType | MaybeTypes],
+ ModuleInfo, Expansions0, Expansions) :-
+ inst_is_ground_1(ModuleInfo, MaybeType, Inst, Expansions0, Expansions1),
+ inst_list_is_ground_2(Insts, MaybeTypes, ModuleInfo,
+ Expansions1, Expansions).
:- pred inst_list_is_ground_or_any_2(list(inst), module_info,
set(inst), set(inst)).
@@ -1869,6 +1941,32 @@
list__member(Inst, Insts)
),
inst_contains_inst_var(Inst, InstVar).
+
+%-----------------------------------------------------------------------------%
+
+:- pred maybe_any_to_bound(maybe(type), module_info, uniqueness, inst).
+:- mode maybe_any_to_bound(in, in, in, out) is semidet.
+
+maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, Inst) :-
+ \+ type_util__is_solver_type(ModuleInfo, Type),
+ (
+ type_constructors(Type, ModuleInfo, Constructors)
+ ->
+ constructors_to_bound_any_insts(Constructors, Uniq,
+ ModuleInfo, BoundInsts0),
+ list__sort_and_remove_dups(BoundInsts0, BoundInsts),
+ Inst = bound(Uniq, BoundInsts)
+ ;
+ classify_type(Type, ModuleInfo, user_type)
+ ->
+ % XXX For a user-defined type for which constructors are not
+ % available (e.g. an abstract type) we should return `nonvar',
+ % but we don't have a `nonvar' inst (yet) so we fail, meaning
+ % that we will use `any' for this type.
+ fail
+ ;
+ Inst = ground(Uniq, none)
+ ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/inst_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inst_util.m,v
retrieving revision 1.25
diff -u -r1.25 inst_util.m
--- compiler/inst_util.m 15 Mar 2003 03:08:53 -0000 1.25
+++ compiler/inst_util.m 22 Jul 2003 07:05:54 -0000
@@ -55,10 +55,10 @@
% Compute the inst that results from abstractly unifying two variables.
:- pred abstractly_unify_inst_functor(is_live, inst, cons_id, list(inst),
- list(is_live), unify_is_real, module_info,
- inst, determinism, module_info).
-:- mode abstractly_unify_inst_functor(in, in, in, in, in, in, in, out, out, out)
- is semidet.
+ list(is_live), unify_is_real, (type), module_info,
+ inst, determinism, module_info).
+:- mode abstractly_unify_inst_functor(in, in, in, in, in, in, in, in,
+ out, out, out) is semidet.
% Compute the inst that results from abstractly unifying
% a variable with a functor.
@@ -484,11 +484,12 @@
% with a functor.
abstractly_unify_inst_functor(Live, InstA, ConsId, ArgInsts, ArgLives,
- Real, ModuleInfo0, Inst, Det, ModuleInfo) :-
+ Real, Type, ModuleInfo0, Inst, Det, ModuleInfo) :-
inst_expand(ModuleInfo0, InstA, InstA2),
( InstA2 = constrained_inst_vars(InstVars, InstA3) ->
abstractly_unify_inst_functor(Live, InstA3, ConsId, ArgInsts,
- ArgLives, Real, ModuleInfo0, Inst0, Det, ModuleInfo),
+ ArgLives, Real, Type, ModuleInfo0, Inst0, Det,
+ ModuleInfo),
(
inst_matches_final(Inst0, InstA3, ModuleInfo)
->
@@ -514,35 +515,43 @@
)
;
abstractly_unify_inst_functor_2(Live, InstA2, ConsId, ArgInsts,
- ArgLives, Real, ModuleInfo0, Inst, Det, ModuleInfo)
+ ArgLives, Real, Type, ModuleInfo0, Inst, Det,
+ ModuleInfo)
).
:- pred abstractly_unify_inst_functor_2(is_live, inst, cons_id, list(inst),
- list(is_live), unify_is_real, module_info,
+ list(is_live), unify_is_real, (type), module_info,
inst, determinism, module_info).
-:- mode abstractly_unify_inst_functor_2(in, in, in, in, in, in, in,
+:- mode abstractly_unify_inst_functor_2(in, in, in, in, in, in, in, in,
out, out, out) is semidet.
- % XXX need to handle `any' insts
-
-abstractly_unify_inst_functor_2(live, not_reached, _, _, _, _, M,
+abstractly_unify_inst_functor_2(live, not_reached, _, _, _, _, _, M,
not_reached, erroneous, M).
abstractly_unify_inst_functor_2(live, free, ConsId, Args0, ArgLives, _Real,
- ModuleInfo0,
+ _, ModuleInfo0,
bound(unique, [functor(ConsId, Args)]), det,
ModuleInfo) :-
inst_list_is_ground_or_any_or_dead(Args0, ArgLives, ModuleInfo0),
maybe_make_shared_inst_list(Args0, ArgLives, ModuleInfo0,
Args, ModuleInfo).
+abstractly_unify_inst_functor_2(live, any(Uniq), ConsId, ArgInsts,
+ ArgLives, Real, Type, ModuleInfo0, Inst, Det, ModuleInfo) :-
+ % We only allow `any' to unify with a functor if we know that
+ % the type is not a solver type.
+ \+ type_util__is_solver_type(ModuleInfo0, Type),
+ make_any_inst_list_lives(ArgInsts, live, ArgLives, Uniq, Real,
+ ModuleInfo0, AnyArgInsts, Det, ModuleInfo),
+ Inst = bound(Uniq, [functor(ConsId, AnyArgInsts)]).
+
abstractly_unify_inst_functor_2(live, bound(Uniq, ListX), ConsId, Args,
- ArgLives, Real, M0, bound(Uniq, List), Det, M) :-
+ ArgLives, Real, _, M0, bound(Uniq, List), Det, M) :-
abstractly_unify_bound_inst_list_lives(ListX, ConsId, Args, ArgLives,
Real, M0, List, Det, M).
abstractly_unify_inst_functor_2(live, ground(Uniq, _), ConsId, ArgInsts,
- ArgLives, Real, M0, Inst, Det, M) :-
+ ArgLives, Real, _, M0, Inst, Det, M) :-
make_ground_inst_list_lives(ArgInsts, live, ArgLives, Uniq, Real, M0,
GroundArgInsts, Det, M),
Inst = bound(Uniq, [functor(ConsId, GroundArgInsts)]).
@@ -551,20 +560,27 @@
% _, _) :-
% fail.
-abstractly_unify_inst_functor_2(dead, not_reached, _, _, _, _, M,
+abstractly_unify_inst_functor_2(dead, not_reached, _, _, _, _, _, M,
not_reached, erroneous, M).
-abstractly_unify_inst_functor_2(dead, free, ConsId, Args, _ArgLives, _Real, M,
- bound(unique, [functor(ConsId, Args)]), det, M).
+abstractly_unify_inst_functor_2(dead, free, ConsId, Args, _ArgLives, _Real, _,
+ M, bound(unique, [functor(ConsId, Args)]), det, M).
+
+abstractly_unify_inst_functor_2(dead, any(Uniq), ConsId, ArgInsts,
+ _ArgLives, Real, Type, ModuleInfo0, Inst, Det, ModuleInfo) :-
+ \+ type_util__is_solver_type(ModuleInfo0, Type),
+ make_any_inst_list(ArgInsts, dead, Uniq, Real, ModuleInfo0,
+ AnyArgInsts, Det, ModuleInfo),
+ Inst = bound(Uniq, [functor(ConsId, AnyArgInsts)]).
abstractly_unify_inst_functor_2(dead, bound(Uniq, ListX), ConsId, Args,
- _ArgLives, Real, M0, bound(Uniq, List), Det, M) :-
+ _ArgLives, Real, _, M0, bound(Uniq, List), Det, M) :-
ListY = [functor(ConsId, Args)],
abstractly_unify_bound_inst_list(dead, ListX, ListY, Real, M0,
List, Det, M).
abstractly_unify_inst_functor_2(dead, ground(Uniq, _), ConsId, ArgInsts,
- _ArgLives, Real, M0, Inst, Det, M) :-
+ _ArgLives, Real, _, M0, Inst, Det, M) :-
make_ground_inst_list(ArgInsts, dead, Uniq, Real, M0,
GroundArgInsts, Det, M),
Inst = bound(Uniq, [functor(ConsId, GroundArgInsts)]).
@@ -1090,6 +1106,26 @@
Inst, Det1, ModuleInfo1),
make_any_inst_list(Insts0, Live, Uniq, Real, ModuleInfo1,
Insts, Det2, ModuleInfo),
+ det_par_conjunction_detism(Det1, Det2, Det).
+
+:- pred make_any_inst_list_lives(list(inst), is_live, list(is_live),
+ uniqueness, unify_is_real,
+ module_info, list(inst), determinism, module_info).
+:- mode make_any_inst_list_lives(in, in, in, in, in, in, out, out, out)
+ is semidet.
+
+make_any_inst_list_lives([], _, _, _, _, ModuleInfo, [], det, ModuleInfo).
+make_any_inst_list_lives([Inst0 | Insts0], Live, [ArgLive | ArgLives],
+ Uniq, Real, ModuleInfo0, [Inst | Insts], Det, ModuleInfo) :-
+ ( Live = live, ArgLive = live ->
+ BothLive = live
+ ;
+ BothLive = dead
+ ),
+ make_any_inst(Inst0, BothLive, Uniq, Real, ModuleInfo0,
+ Inst, Det1, ModuleInfo1),
+ make_any_inst_list_lives(Insts0, Live, ArgLives, Uniq, Real,
+ ModuleInfo1, Insts, Det2, ModuleInfo),
det_par_conjunction_detism(Det1, Det2, Det).
%-----------------------------------------------------------------------------%
Index: compiler/instmap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/instmap.m,v
retrieving revision 1.30
diff -u -r1.30 instmap.m
--- compiler/instmap.m 15 Mar 2003 03:08:53 -0000 1.30
+++ compiler/instmap.m 22 Jul 2003 07:05:54 -0000
@@ -550,7 +550,7 @@
list__duplicate(Arity, free, ArgInsts),
(
abstractly_unify_inst_functor(dead, Inst0, ConsId, ArgInsts,
- ArgLives, real_unify, ModuleInfo0, Inst1, _Det,
+ ArgLives, real_unify, Type, ModuleInfo0, Inst1, _Det,
ModuleInfo1)
->
ModuleInfo = ModuleInfo1,
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.143
diff -u -r1.143 intermod.m
--- compiler/intermod.m 22 Jul 2003 07:04:22 -0000 1.143
+++ compiler/intermod.m 22 Jul 2003 07:05:54 -0000
@@ -1034,7 +1034,7 @@
hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
(
TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEqComp0,
- ReservedTag, MaybeForeign0)
+ ReservedTag, IsSolverType, MaybeForeign0)
->
intermod__resolve_unify_compare_overloading(ModuleInfo,
TypeCtor, MaybeUserEqComp0, MaybeUserEqComp,
@@ -1051,15 +1051,15 @@
Info3 = Info2
),
TypeBody = du_type(Ctors, Tags, Enum, MaybeUserEqComp,
- ReservedTag, MaybeForeign),
+ ReservedTag, IsSolverType, MaybeForeign),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
;
- TypeBody0 = foreign_type(ForeignTypeBody0)
+ TypeBody0 = foreign_type(ForeignTypeBody0, IsSolverType)
->
intermod__resolve_foreign_type_body_overloading(ModuleInfo,
TypeCtor, ForeignTypeBody0, ForeignTypeBody,
Info1, Info3),
- TypeBody = foreign_type(ForeignTypeBody),
+ TypeBody = foreign_type(ForeignTypeBody, IsSolverType),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
;
Info3 = Info1,
@@ -1291,24 +1291,26 @@
{ hlds_data__get_type_defn_context(TypeDefn, Context) },
{ TypeCtor = Name - Arity },
(
- { Body = du_type(Ctors, _, _, MaybeEqualityPred, _, _) },
- { TypeBody = du_type(Ctors, MaybeEqualityPred) }
+ { Ctors = Body ^ du_type_ctors },
+ { IsSolverType = Body ^ du_type_is_solver_type },
+ { MaybeEqualityPred = Body ^ du_type_usereq },
+ { TypeBody = du_type(Ctors, IsSolverType, MaybeEqualityPred) }
;
{ Body = eqv_type(EqvType) },
{ TypeBody = eqv_type(EqvType) }
;
- { Body = abstract_type },
- { TypeBody = abstract_type }
+ { Body = abstract_type(IsSolverType) },
+ { TypeBody = abstract_type(IsSolverType) }
;
- { Body = foreign_type(_) },
- { TypeBody = abstract_type }
+ { Body = foreign_type(_, IsSolverType) },
+ { TypeBody = abstract_type(IsSolverType) }
),
mercury_output_item(type_defn(VarSet, Name, Args, TypeBody, true),
Context),
(
- { Body = foreign_type(ForeignTypeBody)
- ; Body = du_type(_, _, _, _, _, yes(ForeignTypeBody))
+ { Body = foreign_type(ForeignTypeBody, _)
+ ; Body ^ du_type_is_foreign_type = yes(ForeignTypeBody)
},
{ ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC,
MaybeJava) }
@@ -1342,7 +1344,7 @@
[]
),
(
- { Body = du_type(_, _, _, _, ReservedTag, _) },
+ { ReservedTag = Body ^ du_type_reserved_tag },
{ ReservedTag = yes }
->
mercury_output_item(pragma(reserve_tag(Name, Arity)),
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.29
diff -u -r1.29 magic_util.m
--- compiler/magic_util.m 27 May 2003 05:57:12 -0000 1.29
+++ compiler/magic_util.m 22 Jul 2003 07:05:54 -0000
@@ -1385,14 +1385,14 @@
set(argument_error)::in, set(argument_error)::out,
magic_info::in, magic_info::out) is det.
-magic_util__check_type_defn(du_type(Ctors, _, _, _, _, _),
+magic_util__check_type_defn(du_type(Ctors, _, _, _, _, _, _),
Parents, Errors0, Errors) -->
list__foldl2(magic_util__check_ctor(Parents), Ctors, Errors0, Errors).
magic_util__check_type_defn(eqv_type(_), _, _, _) -->
{ error("magic_util__check_type_defn: eqv_type") }.
-magic_util__check_type_defn(abstract_type, _, Errors0, Errors) -->
+magic_util__check_type_defn(abstract_type(_), _, Errors0, Errors) -->
{ set__insert(Errors0, abstract, Errors) }.
-magic_util__check_type_defn(foreign_type(_), _, _, _) -->
+magic_util__check_type_defn(foreign_type(_, _), _, _, _) -->
{ error("magic_util__check_type_defn: foreign_type") }.
:- pred magic_util__check_ctor(set(type_ctor)::in, constructor::in,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.443
diff -u -r1.443 make_hlds.m
--- compiler/make_hlds.m 22 Jul 2003 07:04:22 -0000 1.443
+++ compiler/make_hlds.m 24 Jul 2003 00:14:16 -0000
@@ -1008,16 +1008,19 @@
add_pragma_foreign_type(Context, item_status(ImportStatus, NeedQual),
ForeignType, TVarSet, Name, Args,
UserEqComp, Module0, Module) -->
+ { IsSolverType = non_solver_type },
{ ForeignType = il(ILForeignType),
Body = foreign_type(
foreign_type_body(yes(ILForeignType - UserEqComp),
- no, no))
+ no, no), IsSolverType)
; ForeignType = c(CForeignType),
Body = foreign_type(foreign_type_body(no,
- yes(CForeignType - UserEqComp), no))
+ yes(CForeignType - UserEqComp), no),
+ IsSolverType)
; ForeignType = java(JavaForeignType),
Body = foreign_type(foreign_type_body(no, no,
- yes(JavaForeignType - UserEqComp)))
+ yes(JavaForeignType - UserEqComp)),
+ IsSolverType)
},
{ Cond = true },
@@ -1031,7 +1034,7 @@
{ hlds_data__get_type_defn_status(OldDefn, OldStatus) },
{ hlds_data__get_type_defn_body(OldDefn, OldBody) },
(
- { OldBody = abstract_type },
+ { OldBody = abstract_type(_) },
{ status_is_exported_to_non_submodules(OldStatus,
no) },
{ status_is_exported_to_non_submodules(ImportStatus,
@@ -1109,7 +1112,8 @@
;
{ TypeBody0 = du_type(Body, _CtorTags0, _IsEnum0,
- EqualityPred, ReservedTag0, IsForeign) }
+ EqualityPred, ReservedTag0, IsSolverType,
+ IsForeign) }
->
(
{ ReservedTag0 = yes },
@@ -1140,7 +1144,8 @@
{ assign_constructor_tags(Body, TypeCtor, ReservedTag,
Globals, CtorTags, IsEnum) },
{ TypeBody = du_type(Body, CtorTags, IsEnum,
- EqualityPred, ReservedTag, IsForeign) },
+ EqualityPred, ReservedTag, IsSolverType,
+ IsForeign) },
{ hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
TypeDefn) },
{ map__set(Types0, TypeCtor, TypeDefn, Types) },
@@ -2228,16 +2233,16 @@
:- mode module_add_type_defn_2(in, in, in, in, in,
in, in, in, out, di, uo) is det.
-module_add_type_defn_2(Module0, TVarSet, Name, Args, Body, _Cond, Context,
+module_add_type_defn_2(Module0, TVarSet, Name, Args, Body0, _Cond, Context,
item_status(Status0, NeedQual), Module) -->
{ module_info_types(Module0, Types0) },
{ list__length(Args, Arity) },
{ TypeCtor = Name - Arity },
{
(
- Body = abstract_type
+ Body0 = abstract_type(_)
;
- Body = du_type(_, _, _, _, _, _),
+ Body0 = du_type(_, _, _, _, _, _, _),
string__suffix(term__context_file(Context), ".int2")
% If the type definition comes from a .int2 file then
% we need to treat it as abstract. The constructors
@@ -2249,18 +2254,38 @@
;
Status1 = Status0
},
- {
+ (
% the type is exported if *any* occurrence is exported,
% even a previous abstract occurrence
- map__search(Types0, TypeCtor, OldDefn)
+ { map__search(Types0, TypeCtor, OldDefn0) }
->
- hlds_data__get_type_defn_status(OldDefn, OldStatus),
- combine_status(Status1, OldStatus, Status),
- MaybeOldDefn = yes(OldDefn)
+ { hlds_data__get_type_defn_status(OldDefn0, OldStatus) },
+ { combine_status(Status1, OldStatus, Status) },
+ { hlds_data__get_type_defn_body(OldDefn0, OldBody0) },
+ { combine_is_solver_type(OldBody0, OldBody, Body0, Body) },
+ ( { is_solver_type_is_inconsistent(OldBody, Body) } ->
+ % The existing definition has an is_solver_type
+ % annotation which is different to the current
+ % definition.
+ { module_info_incr_errors(Module0, Module) },
+ { Pieces = [words("In definition of type"),
+ fixed(describe_sym_name_and_arity(
+ Name / Arity) ++ ":"), nl,
+ words("error: all definitions of a type must"),
+ words("have consistent `solver'"),
+ words("annotations")] },
+ error_util__write_error_pieces(Context, 0, Pieces),
+ { MaybeOldDefn = no }
+ ;
+ { hlds_data__set_type_defn_body(OldDefn0, OldBody,
+ OldDefn) },
+ { MaybeOldDefn = yes(OldDefn) }
+ )
;
MaybeOldDefn = no,
- Status = Status1
- },
+ Status = Status1,
+ Body = Body0
+ ),
{ hlds_data__set_type_defn(TVarSet, Args, Body, Status,
NeedQual, Context, T) },
(
@@ -2273,7 +2298,7 @@
{ hlds_data__get_type_defn_status(T2, OrigStatus) },
{ hlds_data__get_type_defn_need_qualifier(T2,
OrigNeedQual) },
- { Body_2 \= abstract_type }
+ { Body_2 \= abstract_type(_) }
->
globals__io_get_target(Target),
globals__io_lookup_bool_option(make_optimization_interface,
@@ -2281,7 +2306,7 @@
(
% then if this definition was abstract, ignore it
% (but update the status of the old defn if necessary)
- { Body = abstract_type }
+ { Body = abstract_type(_) }
->
{
Status = OrigStatus
@@ -2370,6 +2395,50 @@
)
).
+ % We do not have syntax for adding `solver' annotations to
+ % `:- pragma foreign_type' declarations, so foreign_type bodies
+ % default to having an is_solver_type field of `non_solver_type'.
+ % If another declaration for the type has a `solver' annotation then
+ % we must update the foreign_type body to reflect this.
+:- pred combine_is_solver_type(hlds_type_body::in, hlds_type_body::out,
+ hlds_type_body::in, hlds_type_body::out) is det.
+
+combine_is_solver_type(OldBody0, OldBody, Body0, Body) :-
+ (
+ OldBody0 = foreign_type(OldForeignTypeBody, non_solver_type),
+ maybe_get_body_is_solver_type(Body0, solver_type)
+ ->
+ OldBody = foreign_type(OldForeignTypeBody, solver_type),
+ Body = Body0
+ ;
+ maybe_get_body_is_solver_type(OldBody0, solver_type),
+ Body0 = foreign_type(ForeignTypeBody, non_solver_type)
+ ->
+ OldBody = OldBody0,
+ Body = foreign_type(ForeignTypeBody, solver_type)
+ ;
+ OldBody = OldBody0,
+ Body = Body0
+ ).
+
+ % Succeed iff the two type bodies have inconsistent is_solver_type
+ % annotations.
+:- pred is_solver_type_is_inconsistent(hlds_type_body::in, hlds_type_body::in)
+ is semidet.
+
+is_solver_type_is_inconsistent(OldBody, Body) :-
+ maybe_get_body_is_solver_type(OldBody, OldIsSolverType),
+ maybe_get_body_is_solver_type(Body, IsSolverType),
+ OldIsSolverType \= IsSolverType.
+
+:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
+ is semidet.
+
+maybe_get_body_is_solver_type(Body, Body ^ du_type_is_solver_type).
+maybe_get_body_is_solver_type(abstract_type(IsSolverType), IsSolverType).
+maybe_get_body_is_solver_type(foreign_type(_, IsSolverType), IsSolverType).
+
+
% check_foreign_type_visibility(OldStatus, NewDefnStatus).
%
% Check that the visibility of the new definition for
@@ -2404,7 +2473,8 @@
{ hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual) },
(
- { Body = du_type(ConsList, _, _, _, ReservedTag, _) },
+ { ConsList = Body ^ du_type_ctors },
+ { ReservedTag = Body ^ du_type_reserved_tag },
{ module_info_ctors(Module0, Ctors0) },
{ module_info_get_partial_qualifier_info(Module0, PQInfo) },
check_for_errors(
@@ -2432,7 +2502,7 @@
Module2 = Module1
}
;
- { Body = abstract_type },
+ { Body = abstract_type(_) },
{ FoundError1 = no },
{ Module2 = Module0 }
;
@@ -2440,7 +2510,7 @@
{ FoundError1 = no },
{ Module2 = Module0 }
;
- { Body = foreign_type(ForeignTypeBody) },
+ { Body = foreign_type(ForeignTypeBody, _) },
check_foreign_type(TypeCtor, ForeignTypeBody,
Context, FoundError1, Module0, Module2)
),
@@ -2560,8 +2630,8 @@
% if we are making the optimization interface so that it gets
% output in the .opt file.
merge_foreign_type_bodies(Target, MakeOptInterface,
- foreign_type(ForeignTypeBody0),
- Body1 @ du_type(_, _, _, _, _, MaybeForeignTypeBody1), Body) :-
+ foreign_type(ForeignTypeBody0, IsSolverType), Body1, Body) :-
+ MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
( MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
; MaybeForeignTypeBody1 = no,
ForeignTypeBody1 = foreign_type_body(no, no, no)
@@ -2572,16 +2642,17 @@
have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
MakeOptInterface = no
->
- Body = foreign_type(ForeignTypeBody)
+ Body = foreign_type(ForeignTypeBody, IsSolverType)
;
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
).
merge_foreign_type_bodies(Target, MakeOptInterface,
- Body0 @ du_type(_, _, _, _, _, _),
- Body1 @ foreign_type(_), Body) :-
+ Body0 @ du_type(_, _, _, _, _, _, _),
+ Body1 @ foreign_type(_, _), Body) :-
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
-merge_foreign_type_bodies(_, _, foreign_type(Body0), foreign_type(Body1),
- foreign_type(Body)) :-
+merge_foreign_type_bodies(_, _, foreign_type(Body0, _IsSolverType0),
+ foreign_type(Body1, IsSolverType),
+ foreign_type(Body, IsSolverType)) :-
merge_foreign_type_bodies_2(Body0, Body1, Body).
:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
@@ -2687,21 +2758,22 @@
:- pred convert_type_defn(type_defn, type_ctor, globals, hlds_type_body).
:- mode convert_type_defn(in, in, in, out) is det.
-convert_type_defn(du_type(Body, EqualityPred), TypeCtor, Globals,
+convert_type_defn(du_type(Body, IsSolverType, EqualityPred), TypeCtor, Globals,
du_type(Body, CtorTags, IsEnum, EqualityPred,
- ReservedTagPragma, IsForeign)) :-
+ ReservedTagPragma, IsSolverType, IsForeign)) :-
% Initially, when we first see the `:- type' definition,
% we assign the constructor tags assuming that there is no
% `:- pragma reserve_tag' declaration for this type.
% (If it turns out that there was one, then we will recompute the
- % constructor tags by callling assign_constructor_tags again,
+ % constructor tags by calling assign_constructor_tags again,
% with ReservedTagPragma = yes, when processing the pragma.)
ReservedTagPragma = no,
- assign_constructor_tags(Body, TypeCtor, ReservedTagPragma, Globals,
- CtorTags, IsEnum),
+ assign_constructor_tags(Body, TypeCtor, ReservedTagPragma,
+ Globals, CtorTags, IsEnum),
IsForeign = no.
convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
-convert_type_defn(abstract_type, _, _, abstract_type).
+convert_type_defn(abstract_type(IsSolverType), _, _,
+ abstract_type(IsSolverType)).
:- pred ctors_add(list(constructor), type_ctor, tvarset, need_qualifier,
partial_qualifier_info, prog_context, import_status,
@@ -3711,10 +3783,9 @@
status_defined_in_this_module(Status, yes)
->
(
- Body = du_type(Ctors, _, IsEnum, _,
- UserDefinedEquality, _),
- IsEnum = no,
- UserDefinedEquality = no,
+ Ctors = Body ^ du_type_ctors,
+ Body ^ du_type_is_enum = no,
+ Body ^ du_type_usereq = no,
module_info_globals(Module0, Globals),
globals__lookup_int_option(Globals,
compare_specialization, CompareSpec),
@@ -3787,7 +3858,7 @@
Module = Module0
;
SpecialPredId = compare,
- ( TypeBody = du_type(_, _, _, yes(_), _, _) ->
+ ( TypeBody ^ du_type_usereq = yes(_) ->
% The compiler generated comparison
% procedure prints an error message,
% since comparisons of types with
@@ -3828,7 +3899,7 @@
->
pred_info_set_import_status(PredInfo0, Status, PredInfo1)
;
- TypeBody = du_type(_, _, _, yes(_), _, _),
+ TypeBody ^ du_type_usereq = yes(_),
pred_info_import_status(PredInfo0, OldStatus),
OldStatus = pseudo_imported,
status_is_imported(Status, no)
@@ -3934,7 +4005,7 @@
import_status::out) is det.
add_special_pred_unify_status(TypeBody, Status0, Status) :-
- ( TypeBody = du_type(_, _, _, yes(_), _, _) ->
+ ( TypeBody ^ du_type_usereq = yes(_) ->
% If the type has user-defined equality,
% then we create a real unify predicate
% for it, whose body calls the user-specified
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.232
diff -u -r1.232 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 22 Jul 2003 07:04:24 -0000 1.232
+++ compiler/mercury_to_mercury.m 22 Jul 2003 07:05:54 -0000
@@ -1732,14 +1732,15 @@
type_defn, prog_context, io__state, io__state).
:- mode mercury_output_type_defn(in, in, in, in, in, di, uo) is det.
-mercury_output_type_defn(VarSet, Name, Args, abstract_type, Context) -->
- io__write_string(":- type "),
+mercury_output_type_defn(VarSet, Name, Args, abstract_type(IsSolverType),
+ Context) -->
+ mercury_output_begin_type_decl(IsSolverType),
{ construct_qualified_term(Name, Args, Context, TypeTerm) },
mercury_output_term(TypeTerm, VarSet, no, next_to_graphic_token),
io__write_string(".\n").
mercury_output_type_defn(VarSet, Name, Args, eqv_type(Body), Context) -->
- io__write_string(":- type "),
+ mercury_output_begin_type_decl(non_solver_type),
{ construct_qualified_term(Name, Args, Context, TypeTerm) },
mercury_output_term(TypeTerm, VarSet, no),
io__write_string(" == "),
@@ -1747,8 +1748,8 @@
io__write_string(".\n").
mercury_output_type_defn(VarSet, Name, Args,
- du_type(Ctors, MaybeEqCompare), Context) -->
- io__write_string(":- type "),
+ du_type(Ctors, IsSolverType, MaybeEqCompare), Context) -->
+ mercury_output_begin_type_decl(IsSolverType),
{ construct_qualified_term(Name, Args, Context, TypeTerm) },
mercury_output_term(TypeTerm, VarSet, no),
io__write_string("\n\t--->\t"),
@@ -1760,6 +1761,14 @@
),
mercury_output_equality_compare_preds(MaybeEqCompare),
io__write_string("\n\t.\n").
+
+:- pred mercury_output_begin_type_decl(is_solver_type, io__state, io__state).
+:- mode mercury_output_begin_type_decl(in, di, uo) is det.
+
+mercury_output_begin_type_decl(solver_type) -->
+ io__write_string(":- solver type ").
+mercury_output_begin_type_decl(non_solver_type) -->
+ io__write_string(":- type ").
:- pred mercury_output_equality_compare_preds(maybe(unify_compare)::in,
io__state::di, io__state::uo) is det.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.130
diff -u -r1.130 ml_code_gen.m
--- compiler/ml_code_gen.m 14 May 2003 14:38:43 -0000 1.130
+++ compiler/ml_code_gen.m 22 Jul 2003 07:05:54 -0000
@@ -895,7 +895,7 @@
hlds_data__get_type_defn_body(TypeDefn, Body),
(
Body = foreign_type(foreign_type_body(MaybeIL,
- _MaybeC, _MaybeJava))
+ _MaybeC, _MaybeJava), _)
->
( MaybeIL = yes(il(_, Location, _) - _) ->
Name = il_assembly_name(mercury_module_name_to_mlds(
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.32
diff -u -r1.32 ml_type_gen.m
--- compiler/ml_type_gen.m 15 Mar 2003 03:08:59 -0000 1.32
+++ compiler/ml_type_gen.m 22 Jul 2003 07:05:54 -0000
@@ -127,12 +127,13 @@
mlds__defns, mlds__defns).
:- mode ml_gen_type_2(in, in, in, in, in, out) is det.
-ml_gen_type_2(abstract_type, _, _, _) --> [].
+ml_gen_type_2(abstract_type(_), _, _, _) --> [].
ml_gen_type_2(eqv_type(_EqvType), _, _, _) --> []. % XXX Fixme!
% For a description of the problems with equivalence types,
% see our BABEL'01 paper "Compiling Mercury to the .NET CLR".
ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeUserEqCompare,
- _ReservedTag, _), ModuleInfo, TypeCtor, TypeDefn) -->
+ _ReservedTag, _IsSolverType, _), ModuleInfo, TypeCtor, TypeDefn)
+ -->
% XXX we probably shouldn't ignore _ReservedTag
{ ml_gen_equality_members(MaybeUserEqCompare, MaybeEqualityMembers) },
( { IsEnum = yes } ->
@@ -143,7 +144,7 @@
Ctors, TagValues, MaybeEqualityMembers)
).
% XXX Fixme! Same issues here as for eqv_type/1.
-ml_gen_type_2(foreign_type(_), _, _, _) --> [].
+ml_gen_type_2(foreign_type(_, _), _, _, _) --> [].
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.66
diff -u -r1.66 ml_unify_gen.m
--- compiler/ml_unify_gen.m 20 Jun 2003 12:45:45 -0000 1.66
+++ compiler/ml_unify_gen.m 22 Jul 2003 07:05:54 -0000
@@ -1890,7 +1890,7 @@
module_info_types(ModuleInfo, TypeTable),
TypeDefn = map__lookup(TypeTable, TypeCtor),
hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody),
- ( TypeDefnBody = du_type(Ctors, TagValues, _, _, _ReservedTag, _) ->
+ ( TypeDefnBody = du_type(Ctors, TagValues, _, _, _ReservedTag, _, _) ->
% XXX we probably shouldn't ignore ReservedTag here
(
(some [Ctor] (
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.103
diff -u -r1.103 mlds.m
--- compiler/mlds.m 18 Jun 2003 15:09:46 -0000 1.103
+++ compiler/mlds.m 22 Jul 2003 07:05:54 -0000
@@ -1714,7 +1714,8 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(foreign_type_body(MaybeIL, MaybeC, MaybeJava))
+ Body = foreign_type(foreign_type_body(MaybeIL, MaybeC,
+ MaybeJava), _)
->
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.152
diff -u -r1.152 mode_util.m
--- compiler/mode_util.m 26 May 2003 09:00:02 -0000 1.152
+++ compiler/mode_util.m 22 Jul 2003 07:05:54 -0000
@@ -149,13 +149,21 @@
list(inst), list(inst)).
:- mode propagate_types_into_inst_list(in, in, in, in, out) is det.
- % Convert a list of constructors to a list of bound_insts.
+ % Convert a list of constructors to a list of bound_insts where the
+ % arguments are `ground'.
% Note that the list(bound_inst) is not sorted and may contain
% duplicates.
:- pred constructors_to_bound_insts(list(constructor), uniqueness, module_info,
list(bound_inst)).
:- mode constructors_to_bound_insts(in, in, in, out) is det.
+ % Convert a list of constructors to a list of bound_insts where the
+ % arguments are `any'.
+ % Note that the list(bound_inst) is not sorted and may contain
+ % duplicates.
+:- pred constructors_to_bound_any_insts(list(constructor), uniqueness,
+ module_info, list(bound_inst)).
+:- mode constructors_to_bound_any_insts(in, in, in, out) is det.
% Given the mode of a predicate,
% work out which arguments are live (might be used again
@@ -854,26 +862,34 @@
PredArgModes0, PredArgModes),
PredInstInfo = pred_inst_info(function, PredArgModes, det).
-constructors_to_bound_insts([], _, _, []).
-constructors_to_bound_insts([Ctor | Ctors], Uniq, ModuleInfo,
+constructors_to_bound_insts(Constructors, Uniq, ModuleInfo, BoundInsts) :-
+ constructors_to_bound_insts_2(Constructors, Uniq, ModuleInfo,
+ ground(Uniq, none), BoundInsts).
+
+constructors_to_bound_any_insts(Constructors, Uniq, ModuleInfo, BoundInsts) :-
+ constructors_to_bound_insts_2(Constructors, Uniq, ModuleInfo,
+ any(Uniq), BoundInsts).
+
+:- pred constructors_to_bound_insts_2(list(constructor), uniqueness,
+ module_info, inst, list(bound_inst)).
+:- mode constructors_to_bound_insts_2(in, in, in, in, out) is det.
+
+constructors_to_bound_insts_2([], _, _, _, []).
+constructors_to_bound_insts_2([Ctor | Ctors], Uniq, ModuleInfo, ArgInst,
[BoundInst | BoundInsts]) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args),
- ctor_arg_list_to_inst_list(Args, Uniq, Insts),
+ ctor_arg_list_to_inst_list(Args, ArgInst, Insts),
list__length(Insts, Arity),
BoundInst = functor(cons(Name, Arity), Insts),
- constructors_to_bound_insts(Ctors, Uniq, ModuleInfo, BoundInsts).
+ constructors_to_bound_insts_2(Ctors, Uniq, ModuleInfo, ArgInst,
+ BoundInsts).
-:- pred ctor_arg_list_to_inst_list(list(constructor_arg), uniqueness,
- list(inst)).
+:- pred ctor_arg_list_to_inst_list(list(constructor_arg), (inst), list(inst)).
:- mode ctor_arg_list_to_inst_list(in, in, out) is det.
ctor_arg_list_to_inst_list([], _, []).
-ctor_arg_list_to_inst_list([_Name - _Type | Args], Uniq, [Inst | Insts]) :-
- % The information added by this is not yet used, so it's disabled
- % since it unnecessarily complicates the insts.
- % Inst = defined_inst(typed_ground(Uniq, Type)),
- Inst = ground(Uniq, none),
- ctor_arg_list_to_inst_list(Args, Uniq, Insts).
+ctor_arg_list_to_inst_list([_Name - _Type | Args], Inst, [Inst | Insts]) :-
+ ctor_arg_list_to_inst_list(Args, Inst, Insts).
:- pred propagate_ctor_info_2(list(bound_inst), (type), module_info,
list(bound_inst)).
@@ -911,7 +927,7 @@
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams0),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(Constructors, _, _, _, _, _)
+ Constructors = TypeBody ^ du_type_ctors
->
term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, ArgSubst),
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.59
diff -u -r1.59 modecheck_unify.m
--- compiler/modecheck_unify.m 2 Jun 2003 04:56:29 -0000 1.59
+++ compiler/modecheck_unify.m 22 Jul 2003 07:05:54 -0000
@@ -501,7 +501,7 @@
ExtraGoals1 = no_extra_goals
;
abstractly_unify_inst_functor(LiveX, InstOfX, InstConsId,
- InstArgs, LiveArgs, real_unify, ModuleInfo0,
+ InstArgs, LiveArgs, real_unify, TypeOfX, ModuleInfo0,
UnifyInst, Det1, ModuleInfo1)
->
Inst = UnifyInst,
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.86
diff -u -r1.86 module_qual.m
--- compiler/module_qual.m 18 Jun 2003 09:17:26 -0000 1.86
+++ compiler/module_qual.m 22 Jul 2003 07:05:54 -0000
@@ -644,8 +644,9 @@
:- pred qualify_type_defn(type_defn::in, type_defn::out, mq_info::in,
mq_info::out, io__state::di, io__state::uo) is det.
-qualify_type_defn(du_type(Ctors0, MaybeEqualityPred0),
- du_type(Ctors, MaybeEqualityPred), Info0, Info) -->
+qualify_type_defn(du_type(Ctors0, IsSolverType, MaybeEqualityPred0),
+ du_type(Ctors, IsSolverType, MaybeEqualityPred),
+ Info0, Info) -->
qualify_constructors(Ctors0, Ctors, Info0, Info),
% User-defined equality pred names will be converted into
@@ -655,7 +656,8 @@
{ MaybeEqualityPred = MaybeEqualityPred0 }.
qualify_type_defn(eqv_type(Type0), eqv_type(Type), Info0, Info) -->
qualify_type(Type0, Type, Info0, Info).
-qualify_type_defn(abstract_type, abstract_type, Info, Info) --> [].
+qualify_type_defn(abstract_type(IsSolverType), abstract_type(IsSolverType),
+ Info, Info) --> [].
:- pred qualify_constructors(list(constructor)::in, list(constructor)::out,
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.276
diff -u -r1.276 modules.m
--- compiler/modules.m 22 Jul 2003 07:04:24 -0000 1.276
+++ compiler/modules.m 22 Jul 2003 12:52:24 -0000
@@ -6406,16 +6406,17 @@
make_abstract_defn(type_defn(VarSet, Name, Args, TypeDefn, Cond),
ShortInterfaceKind,
- type_defn(VarSet, Name, Args, abstract_type, Cond)) :-
+ type_defn(VarSet, Name, Args, abstract_type(IsSolverType),
+ Cond)) :-
(
- TypeDefn = du_type(_, _),
+ TypeDefn = du_type(_, IsSolverType, _),
% For the `.int2' files, we need the full definitions of
% discriminated union types. Even if the functors for a type
% are not used within a module, we may need to know them for
% comparing insts, e.g. for comparing `ground' and `bound(...)'.
ShortInterfaceKind = int3
;
- TypeDefn = abstract_type
+ TypeDefn = abstract_type(IsSolverType)
;
TypeDefn = eqv_type(_),
% For the `.int2' files, we need the full definitions of
@@ -6426,7 +6427,8 @@
% But the full definitions are not needed for the `.int3'
% files. So we convert equivalence types into abstract
% types only for the `.int3' files.
- ShortInterfaceKind = int3
+ ShortInterfaceKind = int3,
+ IsSolverType = non_solver_type
).
make_abstract_defn(instance(_, _, _, _, _, _) @ Item0, int2, Item) :-
make_abstract_instance(Item0, Item).
@@ -6439,8 +6441,9 @@
make_abstract_unify_compare(type_defn(VarSet, Name, Args, TypeDefn0, Cond),
int2,
type_defn(VarSet, Name, Args, TypeDefn, Cond)) :-
- TypeDefn0 = du_type(Constructors, yes(_UnifyCompare)),
- TypeDefn = du_type(Constructors, yes(abstract_noncanonical_type)).
+ TypeDefn0 = du_type(Constructors, IsSolverType, yes(_UnifyCompare)),
+ TypeDefn = du_type(Constructors, IsSolverType,
+ yes(abstract_noncanonical_type)).
% All instance declarations must be written
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.54
diff -u -r1.54 post_typecheck.m
--- compiler/post_typecheck.m 5 Jun 2003 04:16:21 -0000 1.54
+++ compiler/post_typecheck.m 22 Jul 2003 07:05:54 -0000
@@ -1643,7 +1643,7 @@
module_info_types(ModuleInfo, Types),
map__lookup(Types, TermTypeCtor, TermTypeDefn),
hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody),
- ( TermTypeBody = du_type(Ctors, _, _, _, _, _) ->
+ ( Ctors = TermTypeBody ^ du_type_ctors ->
get_constructor_containing_field_2(Ctors, FieldName, ConsId,
FieldNumber)
;
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.59
diff -u -r1.59 pragma_c_gen.m
--- compiler/pragma_c_gen.m 26 May 2003 09:00:06 -0000 1.59
+++ compiler/pragma_c_gen.m 22 Jul 2003 07:05:54 -0000
@@ -1218,7 +1218,8 @@
type_to_ctor_and_args(Type, TypeId, _SubTypes),
map__search(Types, TypeId, Defn),
hlds_data__get_type_defn_body(Defn, Body),
- Body = foreign_type(foreign_type_body(_MaybeIL, MaybeC, _MaybeJava))
+ Body = foreign_type(foreign_type_body(_MaybeIL, MaybeC,
+ _MaybeJava), _)
->
( MaybeC = yes(c(Name) - _),
MaybeForeignType = yes(Name)
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.95
diff -u -r1.95 prog_data.m
--- compiler/prog_data.m 22 Jul 2003 07:04:24 -0000 1.95
+++ compiler/prog_data.m 22 Jul 2003 07:05:54 -0000
@@ -203,6 +203,17 @@
; erroneous
; failure.
+ % 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(...)'.
+:- type is_solver_type
+ ---> non_solver_type
+ % The inst `any' is always `bound' for this type.
+ ; solver_type.
+ % The inst `any' is not always `bound' for this type
+ % (i.e. the type was declared with
+ % `:- solver type ...').
+
:- type item_warning
---> item_warning(
maybe(option), % Option controlling whether the
@@ -308,7 +319,6 @@
; reserve_tag(sym_name, arity)
% Typename, Arity
-
%
% Aditi pragmas
%
@@ -900,9 +910,9 @@
% type_defn/3 is defined above as a constructor for item/0
:- type type_defn
- ---> du_type(list(constructor), maybe(unify_compare))
+ ---> du_type(list(constructor), is_solver_type, maybe(unify_compare))
; eqv_type(type)
- ; abstract_type.
+ ; abstract_type(is_solver_type).
:- type constructor
---> ctor(
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.222
diff -u -r1.222 prog_io.m
--- compiler/prog_io.m 22 Jul 2003 07:04:24 -0000 1.222
+++ compiler/prog_io.m 22 Jul 2003 07:05:54 -0000
@@ -1042,8 +1042,9 @@
:- type decl_attribute
---> purity(purity)
; quantifier(quantifier_type, list(var))
- ; constraints(quantifier_type, term).
+ ; constraints(quantifier_type, term)
% the term here is the (not yet parsed) list of constraints
+ ; solver_type.
:- type quantifier_type
---> exist
@@ -1101,8 +1102,7 @@
:- mode process_decl(in, in, in, in, in, out) is semidet.
process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Result) :-
- parse_type_decl(ModuleName, VarSet, TypeDecl, Result0),
- check_no_attributes(Result0, Attributes, Result).
+ parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result).
process_decl(ModuleName, VarSet, "pred", [PredDecl], Attributes, Result) :-
parse_type_decl_pred(ModuleName, VarSet, PredDecl, Attributes, Result).
@@ -1409,8 +1409,9 @@
parse_decl_attribute("all", [TVars, Decl],
quantifier(univ, TVarsList), Decl) :-
parse_list_of_vars(TVars, TVarsList).
+parse_decl_attribute("solver", [Decl], solver_type, Decl).
-:- pred check_no_attributes(maybe1(item), decl_attrs, maybe1(item)).
+:- pred check_no_attributes(maybe1(T), decl_attrs, maybe1(T)).
:- mode check_no_attributes(in, in, out) is det.
check_no_attributes(Result0, Attributes, Result) :-
@@ -1434,6 +1435,7 @@
attribute_description(constraints(univ, _), "type class constraint (`<=')").
attribute_description(constraints(exist, _),
"existentially quantified type class constraint (`=>')").
+attribute_description(solver_type, "solver type specifier").
%-----------------------------------------------------------------------------%
@@ -1463,17 +1465,18 @@
%-----------------------------------------------------------------------------%
-:- pred parse_type_decl(module_name, varset, term, maybe1(item)).
-:- mode parse_type_decl(in, in, in, out) is det.
-parse_type_decl(ModuleName, VarSet, TypeDecl, Result) :-
+:- pred parse_type_decl(module_name, varset, term, decl_attrs, maybe1(item)).
+:- mode parse_type_decl(in, in, in, in, out) is det.
+parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result) :-
(
TypeDecl = term__functor(term__atom(Name), Args, _),
- parse_type_decl_type(ModuleName, Name, Args, Cond, R)
+ parse_type_decl_type(ModuleName, Name, Args, Attributes,
+ Cond, R)
->
R1 = R,
Cond1 = Cond
;
- process_abstract_type(ModuleName, TypeDecl, R1),
+ process_abstract_type(ModuleName, TypeDecl, Attributes, R1),
Cond1 = true
),
process_maybe1(make_type_defn(VarSet, Cond1), R1, Result).
@@ -1494,6 +1497,18 @@
make_external(VarSet0, SymSpec, module_defn(VarSet, external(SymSpec))) :-
varset__coerce(VarSet0, VarSet).
+:- pred get_is_solver_type(decl_attrs, is_solver_type, decl_attrs).
+:- mode get_is_solver_type(in, out, out) is det.
+
+get_is_solver_type(Attributes0, IsSolverType, Attributes) :-
+ ( Attributes0 = [solver_type - _ | Attributes1] ->
+ IsSolverType = solver_type,
+ Attributes = Attributes1
+ ;
+ IsSolverType = non_solver_type,
+ Attributes = Attributes0
+ ).
+
%-----------------------------------------------------------------------------%
% add a warning message to the list of messages
@@ -1516,19 +1531,22 @@
% to the condition for that declaration (if any), and Result to
% a representation of the declaration.
-:- pred parse_type_decl_type(module_name, string, list(term), condition,
- maybe1(processed_type_body)).
-:- mode parse_type_decl_type(in, in, in, out, out) is semidet.
+:- pred parse_type_decl_type(module_name, string, list(term), decl_attrs,
+ condition, maybe1(processed_type_body)).
+:- mode parse_type_decl_type(in, in, in, in, out, out) is semidet.
-parse_type_decl_type(ModuleName, "--->", [H, B], Condition, R) :-
+parse_type_decl_type(ModuleName, "--->", [H, B], Attributes0, Condition, R) :-
/* get_condition(...), */
Condition = true,
get_maybe_equality_compare_preds(ModuleName, B, Body, EqCompare),
- process_du_type(ModuleName, H, Body, EqCompare, R).
+ get_is_solver_type(Attributes0, IsSolverType, Attributes),
+ process_du_type(ModuleName, H, Body, IsSolverType, EqCompare, R0),
+ check_no_attributes(R0, Attributes, R).
-parse_type_decl_type(ModuleName, "==", [H, B], Condition, R) :-
+parse_type_decl_type(ModuleName, "==", [H, B], Attributes, Condition, R) :-
get_condition(B, Body, Condition),
- process_eqv_type(ModuleName, H, Body, R).
+ process_eqv_type(ModuleName, H, Body, R0),
+ check_no_attributes(R0, Attributes, R).
%-----------------------------------------------------------------------------%
@@ -1870,19 +1888,20 @@
% binds Result to a representation of the type information about the
% TypeHead.
% This is for "Head ---> Body" (constructor) definitions.
-:- pred process_du_type(module_name, term, term, maybe1(maybe(unify_compare)),
- maybe1(processed_type_body)).
-:- mode process_du_type(in, in, in, in, out) is det.
-process_du_type(ModuleName, Head, Body, EqualityPred, Result) :-
+:- pred process_du_type(module_name, term, term, is_solver_type,
+ maybe1(maybe(unify_compare)), maybe1(processed_type_body)).
+:- mode process_du_type(in, in, in, in, in, out) is det.
+process_du_type(ModuleName, Head, Body, IsSolverType, EqualityPred, Result) :-
parse_type_defn_head(ModuleName, Head, Body, Result0),
- process_du_type_2(ModuleName, Result0, Body, EqualityPred, Result).
+ process_du_type_2(ModuleName, Result0, Body, IsSolverType,
+ EqualityPred, Result).
-:- pred process_du_type_2(module_name, maybe_functor, term,
+:- pred process_du_type_2(module_name, maybe_functor, term, is_solver_type,
maybe1(maybe(unify_compare)), maybe1(processed_type_body)).
-:- mode process_du_type_2(in, in, in, in, out) is det.
-process_du_type_2(_, error(Error, Term), _, _, error(Error, Term)).
-process_du_type_2(ModuleName, ok(Functor, Args0), Body, MaybeEqualityPred,
- Result) :-
+:- mode process_du_type_2(in, in, in, in, in, out) is det.
+process_du_type_2(_, error(Error, Term), _, _, _, error(Error, Term)).
+process_du_type_2(ModuleName, ok(Functor, Args0), Body, IsSolverType,
+ MaybeEqualityPred, Result) :-
% check that body is a disjunction of constructors
list__map(term__coerce, Args0, Args),
(
@@ -1953,7 +1972,8 @@
(
MaybeEqualityPred = ok(EqualityPred),
Result = ok(processed_type_body(Functor, Args,
- du_type(Constrs, EqualityPred)))
+ du_type(Constrs, IsSolverType,
+ EqualityPred)))
;
MaybeEqualityPred = error(Error, Term),
Result = error(Error, Term)
@@ -1970,18 +1990,23 @@
% binds Result to a representation of the type information about the
% TypeHead.
-:- pred process_abstract_type(module_name, term, maybe1(processed_type_body)).
-:- mode process_abstract_type(in, in, out) is det.
-process_abstract_type(ModuleName, Head, Result) :-
+:- pred process_abstract_type(module_name, term, decl_attrs,
+ maybe1(processed_type_body)).
+:- mode process_abstract_type(in, in, in, out) is det.
+process_abstract_type(ModuleName, Head, Attributes0, Result) :-
dummy_term(Body),
parse_type_defn_head(ModuleName, Head, Body, Result0),
- process_abstract_type_2(Result0, Result).
+ get_is_solver_type(Attributes0, IsSolverType, Attributes),
+ process_abstract_type_2(Result0, IsSolverType, Result1),
+ check_no_attributes(Result1, Attributes, Result).
-:- pred process_abstract_type_2(maybe_functor, maybe1(processed_type_body)).
-:- mode process_abstract_type_2(in, out) is det.
-process_abstract_type_2(error(Error, Term), error(Error, Term)).
-process_abstract_type_2(ok(Functor, Args0),
- ok(processed_type_body(Functor, Args, abstract_type))) :-
+:- pred process_abstract_type_2(maybe_functor, is_solver_type,
+ maybe1(processed_type_body)).
+:- mode process_abstract_type_2(in, in, out) is det.
+process_abstract_type_2(error(Error, Term), _, error(Error, Term)).
+process_abstract_type_2(ok(Functor, Args0), IsSolverType,
+ ok(processed_type_body(Functor, Args,
+ abstract_type(IsSolverType)))) :-
list__map(term__coerce, Args0, Args).
%-----------------------------------------------------------------------------%
Index: compiler/recompilation.check.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.2
diff -u -r1.2 recompilation.check.m
--- compiler/recompilation.check.m 15 Mar 2003 03:09:08 -0000 1.2
+++ compiler/recompilation.check.m 22 Jul 2003 07:05:54 -0000
@@ -1130,10 +1130,10 @@
type_ctor::in, type_defn::in, recompilation_check_info::in,
recompilation_check_info::out) is det.
-check_type_defn_ambiguity_with_functor(_, _, abstract_type) --> [].
+check_type_defn_ambiguity_with_functor(_, _, abstract_type(_)) --> [].
check_type_defn_ambiguity_with_functor(_, _, eqv_type(_)) --> [].
check_type_defn_ambiguity_with_functor(NeedQualifier,
- TypeCtor, du_type(Ctors, _)) -->
+ TypeCtor, du_type(Ctors, _, _)) -->
list__foldl(check_functor_ambiguities(NeedQualifier, TypeCtor),
Ctors).
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.8
diff -u -r1.8 recompilation.usage.m
--- compiler/recompilation.usage.m 8 May 2003 03:39:56 -0000 1.8
+++ compiler/recompilation.usage.m 22 Jul 2003 07:05:54 -0000
@@ -1043,8 +1043,8 @@
:- pred recompilation__usage__find_items_used_by_type_body(hlds_type_body::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
-recompilation__usage__find_items_used_by_type_body(
- du_type(Ctors, _, _, _, _, _)) -->
+recompilation__usage__find_items_used_by_type_body(TypeBody) -->
+ { Ctors = TypeBody ^ du_type_ctors },
list__foldl(
(pred(Ctor::in, in, out) is det -->
{ Ctor = ctor(_, Constraints, _, CtorArgs) },
@@ -1058,8 +1058,8 @@
), Ctors).
recompilation__usage__find_items_used_by_type_body(eqv_type(Type)) -->
recompilation__usage__find_items_used_by_type(Type).
-recompilation__usage__find_items_used_by_type_body(abstract_type) --> [].
-recompilation__usage__find_items_used_by_type_body(foreign_type(_)) --> [].
+recompilation__usage__find_items_used_by_type_body(abstract_type(_)) --> [].
+recompilation__usage__find_items_used_by_type_body(foreign_type(_, _)) --> [].
:- pred recompilation__usage__find_items_used_by_mode_defn(hlds_mode_defn::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.5
diff -u -r1.5 recompilation.version.m
--- compiler/recompilation.version.m 15 Mar 2003 03:09:08 -0000 1.5
+++ compiler/recompilation.version.m 22 Jul 2003 07:05:54 -0000
@@ -253,16 +253,16 @@
{ Item = type_defn(VarSet, Name, Args, Body, Cond) }
->
(
- { Body = abstract_type },
+ { Body = abstract_type(_) },
{ NameItem = Item },
% The body of an abstract type can be recorded
% as used when generating a call to the automatically
% generated unification procedure.
{ BodyItem = Item }
;
- { Body = du_type(_, _) },
+ { Body = du_type(_, IsSolverType, _) },
{ NameItem = type_defn(VarSet, Name, Args,
- abstract_type, Cond) },
+ abstract_type(IsSolverType), Cond) },
{ BodyItem = Item }
;
{ Body = eqv_type(_) },
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.39
diff -u -r1.39 special_pred.m
--- compiler/special_pred.m 22 Jul 2003 07:04:25 -0000 1.39
+++ compiler/special_pred.m 22 Jul 2003 07:10:12 -0000
@@ -202,7 +202,7 @@
% polymorphism__process_generated_pred can't handle calls to
% polymorphic procedures after the initial polymorphism pass.
%
- Body \= foreign_type(_),
+ Body \= foreign_type(_, _),
% The special predicates for types with user-defined
% equality or existentially typed constructors are always
@@ -214,14 +214,14 @@
type_body_has_user_defined_equality_pred(ModuleInfo, Body,
unify_compare(_, _))
;
- Body = du_type(Ctors, _, _, _, _, _),
+ Ctors = Body ^ du_type_ctors,
list__member(Ctor, Ctors),
Ctor = ctor(ExistQTVars, _, _, _),
ExistQTVars \= []
).
can_generate_special_pred_clauses_for_type(ModuleInfo, TypeCtor, Body) :-
- Body \= abstract_type,
+ Body \= abstract_type(_),
\+ type_ctor_has_hand_defined_rtti(TypeCtor, Body),
\+ type_body_has_user_defined_equality_pred(ModuleInfo, Body,
abstract_noncanonical_type).
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.8
diff -u -r1.8 stack_opt.m
--- compiler/stack_opt.m 22 May 2003 05:54:38 -0000 1.8
+++ compiler/stack_opt.m 22 Jul 2003 07:05:54 -0000
@@ -1091,7 +1091,7 @@
{ module_info_types(ModuleInfo, TypeTable) },
{ map__lookup(TypeTable, TypeCtor, TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _, _, _) }
+ { ConsTable = TypeBody ^ du_type_cons_tag_values }
->
{ map__lookup(ConsTable, ConsId, ConsTag) },
{ ConsTag = no_tag ->
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.13
diff -u -r1.13 switch_util.m
--- compiler/switch_util.m 20 Jun 2003 12:45:47 -0000 1.13
+++ compiler/switch_util.m 22 Jul 2003 07:05:54 -0000
@@ -321,7 +321,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- ( TypeBody = du_type(_, ConsTable, _, _, _, _) ->
+ ( ConsTable = TypeBody ^ du_type_cons_tag_values ->
map__count(ConsTable, TypeRange),
MaxEnum = TypeRange - 1
;
@@ -342,7 +342,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = du_type(_, ConsTable, _, _, _, _) ->
+ ( ConsTable = Body ^ du_type_cons_tag_values ->
map__to_assoc_list(ConsTable, ConsList),
switch_util__cons_list_to_tag_list(ConsList, TagList)
;
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.51
diff -u -r1.51 table_gen.m
--- compiler/table_gen.m 29 May 2003 18:17:15 -0000 1.51
+++ compiler/table_gen.m 22 Jul 2003 07:05:54 -0000
@@ -1353,7 +1353,9 @@
map__lookup(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Ctors, _, yes, no, _, _)
+ Ctors = TypeBody ^ du_type_ctors,
+ TypeBody ^ du_type_is_enum = yes,
+ TypeBody ^ du_type_usereq = no
->
list__length(Ctors, EnumRange)
;
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.25
diff -u -r1.25 term_util.m
--- compiler/term_util.m 26 May 2003 09:00:10 -0000 1.25
+++ compiler/term_util.m 22 Jul 2003 07:05:54 -0000
@@ -261,7 +261,7 @@
find_weights_for_type(TypeCtor, TypeDefn, Weights0, Weights) :-
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Constructors, _, _, _, _, _),
+ Constructors = TypeBody ^ du_type_ctors,
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
find_weights_for_cons_list(Constructors, TypeCtor, TypeParams,
Weights0, Weights)
@@ -272,11 +272,11 @@
;
% This type may introduce some functors,
% but we will never see them in this analysis
- TypeBody = abstract_type,
+ TypeBody = abstract_type(_),
Weights = Weights0
;
% This type does not introduce any functors
- TypeBody = foreign_type(_),
+ TypeBody = foreign_type(_, _),
Weights = Weights0
).
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.42
diff -u -r1.42 type_ctor_info.m
--- compiler/type_ctor_info.m 17 Jul 2003 14:40:25 -0000 1.42
+++ compiler/type_ctor_info.m 22 Jul 2003 07:10:41 -0000
@@ -112,7 +112,7 @@
TypeModuleName = ModuleName,
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody \= abstract_type,
+ TypeBody \= abstract_type(_),
\+ type_ctor_has_hand_defined_rtti(TypeCtor, TypeBody),
( are_equivalence_types_expanded(ModuleInfo)
=> TypeBody \= eqv_type(_) )
@@ -147,8 +147,7 @@
;
SpecialPreds = no,
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = du_type(_, _, _, yes(_UserDefinedEquality),
- _, _)
+ Body ^ du_type_usereq = yes(_UserDefinedEquality)
)
->
map__lookup(SpecMap, unify - TypeCtor, UnifyPredId),
@@ -219,10 +218,10 @@
hlds_data__get_type_defn_body(HldsDefn, TypeBody),
Version = type_ctor_info_rtti_version,
(
- TypeBody = abstract_type,
+ TypeBody = abstract_type(_),
error("type_ctor_info__gen_type_ctor_data: abstract_type")
;
- TypeBody = foreign_type(_),
+ TypeBody = foreign_type(_, _),
(
ModuleName = unqualified(ModuleStr1),
builtin_type_ctor(ModuleStr1, TypeName, TypeArity,
@@ -249,7 +248,7 @@
Details = eqv(MaybePseudoTypeInfo)
;
TypeBody = du_type(Ctors, ConsTagMap, Enum, EqualityPred,
- ReservedTag, _),
+ ReservedTag, _, _),
(
EqualityPred = yes(_),
EqualityAxioms = user_defined
@@ -279,7 +278,7 @@
)
),
Flags0 = set__init,
- ( TypeBody = du_type(_, _, _, _, _, _) ->
+ ( TypeBody = du_type(_, _, _, _, _, _, _) ->
Flags1 = set__insert(Flags0, kind_of_du_flag),
( TypeBody ^ du_type_reserved_tag = yes ->
Flags2 = set__insert(Flags1, reserve_tag_flag)
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.122
diff -u -r1.122 type_util.m
--- compiler/type_util.m 22 Jul 2003 07:04:25 -0000 1.122
+++ compiler/type_util.m 22 Jul 2003 12:21:47 -0000
@@ -79,6 +79,14 @@
:- pred type_body_has_user_defined_equality_pred(module_info::in,
hlds_type_body::in, unify_compare::out) is semidet.
+ % Succeed if the inst `any' can be considered `bound' for this type.
+:- pred type_util__is_solver_type(module_info, (type)).
+:- mode type_util__is_solver_type(in, in) is semidet.
+
+:- pred type_body_is_solver_type(module_info, hlds_type_body).
+:- mode type_body_is_solver_type(in, in) is semidet.
+
+
% 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
@@ -563,7 +571,8 @@
; Name = "typeclass_info"
; Name = "base_typeclass_info"
),
- \+ ( Body = du_type(_, _, _, _, _, yes(_)) ; Body = foreign_type(_) ).
+ \+ ( Body = du_type(_, _, _, _, _, _, yes(_))
+ ; Body = foreign_type(_, _) ).
is_introduced_type_info_type(Type) :-
sym_name_and_args(Type, TypeName, _),
@@ -732,9 +741,37 @@
(
TypeBody ^ du_type_usereq = yes(UserEqComp)
;
- TypeBody = foreign_type(ForeignTypeBody),
+ TypeBody = foreign_type(ForeignTypeBody, _),
UserEqComp = foreign_type_body_has_user_defined_equality_pred(
ModuleInfo, ForeignTypeBody)
+ ).
+
+type_util__is_solver_type(ModuleInfo, Type) :-
+ module_info_types(ModuleInfo, TypeTable),
+ ( type_to_ctor_and_args(Type, TypeCtor, _TypeArgs) ->
+ map__search(TypeTable, TypeCtor, TypeDefn),
+ % Type table search will fail for builtin types such as
+ % `int/0'. Such types are not solver types so
+ % type_util__is_solver_type fails too.
+ hlds_data__get_type_defn_body(TypeDefn, TypeBody),
+ type_body_is_solver_type(ModuleInfo, TypeBody)
+ ;
+ % type_to_ctor_and_args will fail for type variables. In that
+ % case we assume that the type may be a solver type.
+ true
+ ).
+
+ % Return the `is_solver_type' field for the type body.
+type_body_is_solver_type(ModuleInfo, TypeBody) :-
+ (
+ TypeBody ^ du_type_is_solver_type = solver_type
+ ;
+ TypeBody = eqv_type(Type),
+ type_util__is_solver_type(ModuleInfo, Type)
+ ;
+ TypeBody = foreign_type(_, solver_type)
+ ;
+ TypeBody = abstract_type(solver_type)
).
% Certain types, e.g. io__state and store__store(S),
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.130
diff -u -r1.130 unify_gen.m
--- compiler/unify_gen.m 20 Jun 2003 12:45:47 -0000 1.130
+++ compiler/unify_gen.m 22 Jul 2003 07:05:54 -0000
@@ -177,7 +177,7 @@
code_info__lookup_type_defn(Type, TypeDefn),
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
{
- TypeBody = du_type(_, ConsTable, _, _, _, _)
+ ConsTable = TypeBody ^ du_type_cons_tag_values
->
map__to_assoc_list(ConsTable, ConsList),
(
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.124
diff -u -r1.124 unify_proc.m
--- compiler/unify_proc.m 22 Jul 2003 07:04:25 -0000 1.124
+++ compiler/unify_proc.m 22 Jul 2003 07:11:54 -0000
@@ -294,7 +294,7 @@
TypeName = qualified(TypeModuleName, _),
module_info_name(ModuleInfo1, ModuleName),
ModuleName = TypeModuleName,
- TypeBody = abstract_type
+ TypeBody = abstract_type(_)
;
type_ctor_has_hand_defined_rtti(TypeCtor,
TypeBody)
@@ -569,11 +569,12 @@
map__from_assoc_list([ConsId - single_functor],
ConsTagValues),
TypeBody = du_type([Ctor], ConsTagValues, IsEnum,
- UnifyPred, ReservedTag, IsForeign),
+ UnifyPred, ReservedTag, IsSolverType, IsForeign),
UnifyPred = no,
IsEnum = no,
IsForeign = no,
ReservedTag = no,
+ IsSolverType = non_solver_type,
construct_type(TypeCtor, TupleArgTypes, Type),
term__context_init(Context)
@@ -741,7 +742,8 @@
UserEqCompare, H1, H2, Context, Clauses)
;
(
- { TypeBody = du_type(Ctors, _, IsEnum, _, _, _) },
+ { Ctors = TypeBody ^ du_type_ctors },
+ { IsEnum = TypeBody ^ du_type_is_enum },
( { IsEnum = yes } ->
%
% Enumerations are atomic types, so modecheck_unify.m
@@ -761,14 +763,14 @@
generate_unify_clauses_eqv_type(EqvType, H1, H2,
Context, Clauses)
;
- { TypeBody = foreign_type(_) },
+ { TypeBody = foreign_type(_, _) },
% If no user defined equality predicate is given,
% we treat foreign_type as if they were an equivalent
% to the builtin type c_pointer.
generate_unify_clauses_eqv_type(c_pointer_type,
H1, H2, Context, Clauses)
;
- { TypeBody = abstract_type },
+ { TypeBody = abstract_type(_) },
{ error("trying to create unify proc for abstract type") }
)
).
@@ -878,7 +880,8 @@
{ error("trying to create index proc for non-canonical type") }
;
(
- { TypeBody = du_type(Ctors, _, IsEnum, _, _, _) },
+ { Ctors = TypeBody ^ du_type_ctors },
+ { IsEnum = TypeBody ^ du_type_is_enum },
( { IsEnum = yes } ->
%
% For enum types, the generated comparison predicate
@@ -903,10 +906,10 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
- { TypeBody = foreign_type(_) },
+ { TypeBody = foreign_type(_, _) },
{ error("trying to create index proc for a foreign type") }
;
- { TypeBody = abstract_type },
+ { TypeBody = abstract_type(_) },
{ error("trying to create index proc for abstract type") }
)
).
@@ -926,7 +929,8 @@
Res, H1, H2, Context, Clauses)
;
(
- { TypeBody = du_type(Ctors, _, IsEnum, _, _, _) },
+ { Ctors = TypeBody ^ du_type_ctors },
+ { IsEnum = TypeBody ^ du_type_is_enum },
( { IsEnum = yes } ->
{ IntType = int_type },
unify_proc__make_fresh_named_var_from_type(IntType,
@@ -957,11 +961,11 @@
generate_compare_clauses_eqv_type(EqvType,
Res, H1, H2, Context, Clauses)
;
- { TypeBody = foreign_type(_) },
+ { TypeBody = foreign_type(_, _) },
generate_compare_clauses_eqv_type(c_pointer_type,
Res, H1, H2, Context, Clauses)
;
- { TypeBody = abstract_type },
+ { TypeBody = abstract_type(_) },
{ error("trying to create compare proc for abstract type") }
)
).
Index: library/ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/ops.m,v
retrieving revision 1.43
diff -u -r1.43 ops.m
--- library/ops.m 5 Dec 2002 03:52:30 -0000 1.43
+++ library/ops.m 22 Jul 2003 07:05:54 -0000
@@ -337,6 +337,7 @@
ops__op_table("rem", after, xfx, 400). % Standard ISO Prolog
ops__op_table("rule", before, fx, 1199). % NU-Prolog extension
ops__op_table("semipure", before, fy, 800). % Mercury extension
+ops__op_table("solver", before, fy, 1181). % Mercury extension
ops__op_table("some", before, fxy, 950). % Mercury/NU-Prolog extension
ops__op_table("then", after, xfx, 1150). % Mercury/NU-Prolog extension
ops__op_table("type", before, fx, 1180). % Mercury extension
Index: tests/invalid/any_mode.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/any_mode.err_exp,v
retrieving revision 1.5
diff -u -r1.5 any_mode.err_exp
--- tests/invalid/any_mode.err_exp 17 Jan 2003 05:57:07 -0000 1.5
+++ tests/invalid/any_mode.err_exp 22 Jul 2003 07:05:55 -0000
@@ -8,8 +8,8 @@
any_mode.m:008: predicate `any_mode.q/1'.
any_mode.m:006: Warning: clause in module interface.
any_mode.m:009: Warning: clause in module interface.
-any_mode.m:005: Inferred :- pred p(int).
-any_mode.m:008: Inferred :- pred q(int).
+any_mode.m:005: Inferred :- pred p((any_mode.foo)).
+any_mode.m:008: Inferred :- pred q((any_mode.foo)).
any_mode.m:006: In clause for `p((any -> ground))':
any_mode.m:006: in argument 1 of call to predicate `any_mode.q/1':
any_mode.m:006: mode error: variable `X' has instantiatedness `any',
Index: tests/invalid/any_mode.m
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/any_mode.m,v
retrieving revision 1.1
diff -u -r1.1 any_mode.m
--- tests/invalid/any_mode.m 14 Sep 1997 09:12:40 -0000 1.1
+++ tests/invalid/any_mode.m 22 Jul 2003 07:05:55 -0000
@@ -6,4 +6,6 @@
p(X) :- q(X).
:- mode q(in).
-q(42).
+q(bar).
+
+:- solver type foo ---> bar ; baz.
--
David Overton Uni of Melbourne +61 3 8344 1354
dmo at cs.mu.oz.au Monash Uni (Clayton) +61 3 9905 5779
http://www.cs.mu.oz.au/~dmo Mobile Phone +61 4 0337 4393
--------------------------------------------------------------------------
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