[m-rev.] for review: add `any_is_bound' pragma
David Overton
dmo at cs.mu.OZ.AU
Thu Jul 17 17:04:28 AEST 2003
Estimated hours taken: 120
Branches: main
This change adds a new pragma `any_is_bound(t/n)' which tells the compiler
that for type t/n 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'. 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'.
This change also provides a new Boolean option `--default-any-is-bound' which,
when set, assumes that `any' is always equivalent to `bound', except for types
t/n for which a `:- pragma any_is_not_bound(t/n)' declaration exists. We plan
to use this option when compiling HAL code because it allows us to use existing
non-solver types (e.g. types defined in the Mercury standard library) without
having to explicitly add a `:- pragma any_is_bound' declaration for each type.
compiler/prog_data.m:
compiler/prog_io_pragma.m:
compiler/make_hlds.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/recompilation.version.m:
compiler/mercury_to_mercury.m:
Handle the new pragmas.
compiler/options.m:
Add the new option.
compiler/hlds_data.m:
Add a field to the type `hlds_type_body' to record whether `any' is
`bound' for the type.
compiler/det_report.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/post_typecheck.m:
compiler/pragma_c_gen.m:
compiler/recompilation.usage.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 `hlds_type_body'.
compiler/type_util.m:
Add predicate `type_util__any_is_bound'.
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 `any' is `bound' for this 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'.
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 17 Jul 2003 05:50:28 -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/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 17 Jul 2003 05:50:28 -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, _AnyIsBound) ->
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.5
diff -u -r1.5 hlds_code_util.m
--- compiler/hlds_code_util.m 5 Jun 2003 04:16:20 -0000 1.5
+++ compiler/hlds_code_util.m 17 Jul 2003 05:50:28 -0000
@@ -91,7 +91,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.76
diff -u -r1.76 hlds_data.m
--- compiler/hlds_data.m 8 May 2003 03:39:53 -0000 1.76
+++ compiler/hlds_data.m 17 Jul 2003 05:50:28 -0000
@@ -328,13 +328,17 @@
% pragma for this type?
du_type_reserved_tag :: bool,
+ % should the `any' inst be considered
+ % `bound' for this type?
+ du_type_any_is_bound :: any_is_bound,
+
% 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, any_is_bound)
+ ; abstract_type(any_is_bound).
:- type foreign_type_body
---> foreign_type_body(
@@ -472,6 +476,19 @@
; reserved_object(type_ctor, sym_name, arity).
% This is for constants which are represented as the
% address of a specially reserved global variable.
+
+:- type any_is_bound
+ ---> any_is_bound
+ % The inst `any' is always `bound' for this type
+ % (i.e. a `:- pragma any_is_bound' declaration was given
+ % for the type).
+ ; any_is_not_bound
+ % The inst `any' is not always `bound' for this type.
+ % (i.e. a `:- pragma any_is_not_bound' declaration was
+ % given for the type).
+ ; default.
+ % Use the default given by the option
+ % `--(no)-default-any-is-bound'.
% The type `tag_bits' holds a primary tag value.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.310
diff -u -r1.310 hlds_out.m
--- compiler/hlds_out.m 27 May 2003 05:57:09 -0000 1.310
+++ compiler/hlds_out.m 17 Jul 2003 05:50:28 -0000
@@ -2974,7 +2974,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, AnyIsBound, Foreign)) -->
io__write_string(" --->\n"),
( { Enum = yes } ->
hlds_out__write_indent(Indent),
@@ -2988,6 +2988,15 @@
;
[]
),
+ ( { AnyIsBound = any_is_bound } ->
+ hlds_out__write_indent(Indent),
+ io__write_string("/* any_is_bound */\n")
+ ; { AnyIsBound = any_is_not_bound } ->
+ hlds_out__write_indent(Indent),
+ io__write_string("/* any_is_not_bound */\n")
+ ;
+ []
+ ),
hlds_out__write_constructors(Indent, Tvarset, Ctors, Tags),
( { MaybeEqualityPred = yes(unify_compare(MaybeEq, MaybeCompare)) } ->
io__write_string("\n"),
@@ -3027,10 +3036,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(_AnyIsBound)) -->
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 17 Jul 2003 05:50:28 -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 any_is_bound for the 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,24 @@
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__any_is_bound(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)
+ ;
+ 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 17 Jul 2003 05:50:28 -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,42 @@
)
;
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
+ type_util__any_is_bound(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 +559,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__any_is_bound(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 +1105,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 17 Jul 2003 05:50:28 -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.142
diff -u -r1.142 intermod.m
--- compiler/intermod.m 27 May 2003 05:57:11 -0000 1.142
+++ compiler/intermod.m 17 Jul 2003 05:50:28 -0000
@@ -1034,7 +1034,7 @@
hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
(
TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEqComp0,
- ReservedTag, MaybeForeign0)
+ ReservedTag, AnyIsBound, 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, AnyIsBound, MaybeForeign),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
;
- TypeBody0 = foreign_type(ForeignTypeBody0)
+ TypeBody0 = foreign_type(ForeignTypeBody0, AnyIsBound)
->
intermod__resolve_foreign_type_body_overloading(ModuleInfo,
TypeCtor, ForeignTypeBody0, ForeignTypeBody,
Info1, Info3),
- TypeBody = foreign_type(ForeignTypeBody),
+ TypeBody = foreign_type(ForeignTypeBody, AnyIsBound),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
;
Info3 = Info1,
@@ -1288,24 +1288,25 @@
{ hlds_data__get_type_defn_context(TypeDefn, Context) },
{ TypeCtor = Name - Arity },
(
- { Body = du_type(Ctors, _, _, MaybeEqualityPred, _, _) },
+ { Ctors = Body ^ du_type_ctors },
+ { MaybeEqualityPred = Body ^ du_type_usereq },
{ TypeBody = du_type(Ctors, MaybeEqualityPred) }
;
{ Body = eqv_type(EqvType) },
{ TypeBody = eqv_type(EqvType) }
;
- { Body = abstract_type },
+ { Body = abstract_type(_) },
{ TypeBody = abstract_type }
;
- { Body = foreign_type(_) },
+ { Body = foreign_type(_, _) },
{ TypeBody = abstract_type }
),
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) }
@@ -1339,11 +1340,33 @@
[]
),
(
- { Body = du_type(_, _, _, _, ReservedTag, _) },
+ { ReservedTag = Body ^ du_type_reserved_tag },
{ ReservedTag = yes }
->
mercury_output_item(pragma(reserve_tag(Name, Arity)),
Context)
+ ;
+ []
+ ),
+ (
+ { AnyIsBound = Body ^ du_type_any_is_bound
+ ; Body = foreign_type(_, AnyIsBound)
+ ; Body = abstract_type(AnyIsBound)
+ }
+ ->
+ (
+ { AnyIsBound = any_is_bound }
+ ->
+ mercury_output_item(pragma(any_is_bound(Name, Arity)),
+ Context)
+ ;
+ { AnyIsBound = any_is_not_bound }
+ ->
+ mercury_output_item(pragma(any_is_not_bound(Name,
+ Arity)), Context)
+ ;
+ []
+ )
;
[]
).
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 17 Jul 2003 05:50:28 -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.442
diff -u -r1.442 make_hlds.m
--- compiler/make_hlds.m 27 May 2003 05:57:13 -0000 1.442
+++ compiler/make_hlds.m 17 Jul 2003 05:50:28 -0000
@@ -554,6 +554,18 @@
{ Pragma = reserve_tag(_, _) },
{ Module = Module0 }
;
+ % Handle pragma any_is_bound decls later on (when we process
+ % clauses -- they need to be handled after the type definitions
+ % have been added).
+ { Pragma = any_is_bound(_, _) },
+ { Module = Module0 }
+ ;
+ % Handle pragma any_is_not_bound decls later on (when we process
+ % clauses -- they need to be handled after the type definitions
+ % have been added).
+ { Pragma = any_is_not_bound(_, _) },
+ { Module = Module0 }
+ ;
{ Pragma = aditi(PredName, Arity) },
maybe_enable_aditi_compilation(Status, Context,
Module0, Module1),
@@ -867,6 +879,18 @@
Context, Module0, Module),
{ Info = Info0 }
;
+ { Pragma = any_is_bound(TypeName, TypeArity) }
+ ->
+ add_pragma_any_is_bound(any_is_bound, TypeName, TypeArity,
+ Status, Context, Module0, Module),
+ { Info = Info0 }
+ ;
+ { Pragma = any_is_not_bound(TypeName, TypeArity) }
+ ->
+ add_pragma_any_is_bound(any_is_not_bound, TypeName, TypeArity,
+ Status, Context, Module0, Module),
+ { Info = Info0 }
+ ;
% don't worry about any pragma declarations other than the
% clause-like pragmas (c_code, tabling and fact_table),
% foreign_type and the termination_info pragma here,
@@ -1008,16 +1032,17 @@
add_pragma_foreign_type(Context, item_status(ImportStatus, NeedQual),
ForeignType, TVarSet, Name, Args,
UserEqComp, Module0, Module) -->
+ { AnyIsBound = default },
{ ForeignType = il(ILForeignType),
Body = foreign_type(
foreign_type_body(yes(ILForeignType - UserEqComp),
- no, no))
+ no, no), AnyIsBound)
; ForeignType = c(CForeignType),
Body = foreign_type(foreign_type_body(no,
- yes(CForeignType - UserEqComp), no))
+ yes(CForeignType - UserEqComp), no), AnyIsBound)
; ForeignType = java(JavaForeignType),
Body = foreign_type(foreign_type_body(no, no,
- yes(JavaForeignType - UserEqComp)))
+ yes(JavaForeignType - UserEqComp)), AnyIsBound)
},
{ Cond = true },
@@ -1031,7 +1056,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 +1134,8 @@
;
{ TypeBody0 = du_type(Body, _CtorTags0, _IsEnum0,
- EqualityPred, ReservedTag0, IsForeign) }
+ EqualityPred, ReservedTag0, AnyIsBound,
+ IsForeign) }
->
(
{ ReservedTag0 = yes },
@@ -1140,7 +1166,8 @@
{ assign_constructor_tags(Body, TypeCtor, ReservedTag,
Globals, CtorTags, IsEnum) },
{ TypeBody = du_type(Body, CtorTags, IsEnum,
- EqualityPred, ReservedTag, IsForeign) },
+ EqualityPred, ReservedTag, AnyIsBound,
+ IsForeign) },
{ hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
TypeDefn) },
{ map__set(Types0, TypeCtor, TypeDefn, Types) },
@@ -1173,6 +1200,187 @@
%-----------------------------------------------------------------------------%
+:- pred add_pragma_any_is_bound(any_is_bound, sym_name, arity, import_status,
+ prog_context, module_info, module_info, io__state, io__state).
+:- mode add_pragma_any_is_bound(in(bound(any_is_bound ; any_is_not_bound)),
+ in, in, in, in, in, out, di, uo) is det.
+
+add_pragma_any_is_bound(AnyIsBound, TypeName, TypeArity, PragmaStatus,
+ Context, Module0, Module) -->
+ { TypeCtor = TypeName - TypeArity },
+ { module_info_types(Module0, Types0) },
+ { TypeStr = error_util__describe_sym_name_and_arity(
+ TypeName / TypeArity) },
+ {
+ AnyIsBound = any_is_bound,
+ PragmaString = "`pragma any_is_bound'"
+ ;
+ AnyIsBound = any_is_not_bound,
+ PragmaString = "`pragma any_is_not_bound'"
+ },
+ { ErrorPieces1 = [
+ words("In"),
+ fixed(PragmaString),
+ words("declaration for"),
+ fixed(TypeStr ++ ":")
+ ] },
+ (
+ { map__search(Types0, TypeCtor, TypeDefn0) }
+ ->
+ { hlds_data__get_type_defn_body(TypeDefn0, TypeBody0) },
+ { hlds_data__get_type_defn_status(TypeDefn0, TypeStatus) },
+ (
+ not {
+ TypeStatus = PragmaStatus
+ ;
+ TypeStatus = abstract_exported,
+ % For `:- pragma any_is_bound' we
+ % allow `exported', `local' or
+ % `exported_to_submodules'.
+ % For `:- pragma any_is_not_bound' we require
+ % `exported'.
+ (
+ AnyIsBound = any_is_bound,
+ ( PragmaStatus = local
+ ; PragmaStatus = exported_to_submodules
+ ; PragmaStatus = exported
+ )
+ ;
+ AnyIsBound = any_is_not_bound,
+ PragmaStatus = exported
+ )
+ }
+ ->
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error:"),
+ fixed(PragmaString),
+ words("declaration must"),
+ words("have the same visibility as the"),
+ words("type definition.")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+
+ ;
+ { AnyIsBound0 = TypeBody0 ^ du_type_any_is_bound }
+ ->
+ maybe_warn_multiple_pragma_any_is_bound(AnyIsBound0,
+ AnyIsBound, TypeStatus, Context, ErrorPieces1,
+ PragmaString, Module0, Module1),
+ %
+ % We passed all the semantic checks.
+ % Mark the type has having any_is_bound.
+ %
+ { TypeBody = TypeBody0 ^
+ du_type_any_is_bound := any_is_bound },
+ { hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
+ TypeDefn) },
+ { map__set(Types0, TypeCtor, TypeDefn, Types) },
+ { module_info_set_types(Module1, Types, Module) }
+ ;
+ { TypeBody0 = foreign_type(ForeignTypeBody,
+ AnyIsBound0) }
+ ->
+ maybe_warn_multiple_pragma_any_is_bound(AnyIsBound0,
+ AnyIsBound, TypeStatus, Context, ErrorPieces1,
+ PragmaString, Module0, Module1),
+ { TypeBody = foreign_type(ForeignTypeBody,
+ AnyIsBound) },
+ { hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
+ TypeDefn) },
+ { map__set(Types0, TypeCtor, TypeDefn, Types) },
+ { module_info_set_types(Module1, Types, Module) }
+ ;
+ { TypeBody0 = abstract_type(AnyIsBound0) }
+ ->
+ maybe_warn_multiple_pragma_any_is_bound(AnyIsBound0,
+ AnyIsBound, TypeStatus, Context, ErrorPieces1,
+ PragmaString, Module0, Module1),
+ { TypeBody = abstract_type(AnyIsBound) },
+ { hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
+ TypeDefn) },
+ { map__set(Types0, TypeCtor, TypeDefn, Types) },
+ { module_info_set_types(Module1, Types, Module) }
+ ;
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error:"),
+ fixed(TypeStr),
+ words("is an equivalence type.")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ;
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error: undefined type"),
+ fixed(TypeStr ++ ".")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ ).
+
+:- pred maybe_warn_multiple_pragma_any_is_bound(any_is_bound, any_is_bound,
+ import_status, prog_context, list(format_component), string,
+ module_info, module_info, io__state, io__state).
+:- mode maybe_warn_multiple_pragma_any_is_bound(in,
+ in(bound(any_is_bound ; any_is_not_bound)), in, in, in, in,
+ in, out, di, uo) is det.
+
+maybe_warn_multiple_pragma_any_is_bound(AnyIsBound0, AnyIsBound, TypeStatus,
+ Context, ErrorPieces1, PragmaString, Module0, Module) -->
+ (
+ { AnyIsBound0 = AnyIsBound },
+ % make doubly sure that we don't get any
+ % spurious warnings with intermodule
+ % optimization...
+ { TypeStatus \= opt_imported }
+ ->
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("warning: multiple"),
+ fixed(PragmaString),
+ words("declarations for the same type.")
+ ] },
+ error_util__write_error_pieces_not_first_line(
+ Context, 0, ErrorPieces2),
+ { Module0 = Module }
+ ;
+ { AnyIsBound0 \= default }
+ ->
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error: contradictory"),
+ fixed(PragmaString),
+ words("declarations for the same type.")
+ ] },
+ error_util__write_error_pieces_not_first_line(
+ Context, 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ % XXX we may want to allow `:- pragma any_is_not_bound' in the
+ % interface and `:- pragma any_is_bound' in the implementation
+ % to allow HAL's reinst facility to be implemented without inst
+ % casts.
+ ;
+ { Module0 = Module }
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred add_pragma_unused_args(pred_or_func, sym_name, arity, mode_num,
list(int), prog_context, module_info, module_info,
io__state, io__state).
@@ -2233,7 +2441,7 @@
{ module_info_types(Module0, Types0) },
{ list__length(Args, Arity) },
{ TypeCtor = Name - Arity },
- { Body = abstract_type ->
+ { Body = abstract_type(_) ->
make_status_abstract(Status0, Status1)
;
Status1 = Status0
@@ -2262,7 +2470,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,
@@ -2270,7 +2478,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
@@ -2393,7 +2601,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(
@@ -2421,7 +2630,7 @@
Module2 = Module1
}
;
- { Body = abstract_type },
+ { Body = abstract_type(_) },
{ FoundError1 = no },
{ Module2 = Module0 }
;
@@ -2429,7 +2638,7 @@
{ FoundError1 = no },
{ Module2 = Module0 }
;
- { Body = foreign_type(ForeignTypeBody) },
+ { Body = foreign_type(ForeignTypeBody, _) },
check_foreign_type(TypeCtor, ForeignTypeBody,
Context, FoundError1, Module0, Module2)
),
@@ -2549,8 +2758,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, _AnyIsBound), Body1, Body) :-
+ MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
( MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
; MaybeForeignTypeBody1 = no,
ForeignTypeBody1 = foreign_type_body(no, no, no)
@@ -2561,16 +2770,18 @@
have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
MakeOptInterface = no
->
- Body = foreign_type(ForeignTypeBody)
+ AnyIsBound = Body1 ^ du_type_any_is_bound,
+ Body = foreign_type(ForeignTypeBody, AnyIsBound)
;
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, _),
+ foreign_type(Body1, AnyIsBound),
+ foreign_type(Body, AnyIsBound)) :-
merge_foreign_type_bodies_2(Body0, Body1, Body).
:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
@@ -2678,19 +2889,20 @@
convert_type_defn(du_type(Body, EqualityPred), TypeCtor, Globals,
du_type(Body, CtorTags, IsEnum, EqualityPred,
- ReservedTagPragma, IsForeign)) :-
+ ReservedTagPragma, AnyIsBoundPragma, 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),
+ AnyIsBoundPragma = default,
+ 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, _, _, abstract_type(default)).
:- pred ctors_add(list(constructor), type_ctor, tvarset, need_qualifier,
partial_qualifier_info, prog_context, import_status,
@@ -3699,10 +3911,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),
@@ -3775,7 +3986,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
@@ -3816,7 +4027,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)
@@ -3922,7 +4133,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.229
diff -u -r1.229 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 26 May 2003 09:00:00 -0000 1.229
+++ compiler/mercury_to_mercury.m 17 Jul 2003 05:50:28 -0000
@@ -633,6 +633,22 @@
add_int(TypeArity),
add_string(").\n")
;
+ { Pragma = any_is_bound(TypeName, TypeArity) },
+ add_string(":- pragma any_is_bound("),
+ mercury_format_bracketed_sym_name(TypeName,
+ next_to_graphic_token),
+ add_string("/"),
+ add_int(TypeArity),
+ add_string(").\n")
+ ;
+ { Pragma = any_is_not_bound(TypeName, TypeArity) },
+ add_string(":- pragma any_is_not_bound("),
+ mercury_format_bracketed_sym_name(TypeName,
+ next_to_graphic_token),
+ add_string("/"),
+ add_int(TypeArity),
+ add_string(").\n")
+ ;
{ Pragma = aditi(Pred, Arity) },
mercury_output_pragma_decl(Pred, Arity, predicate, "aditi")
;
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 17 Jul 2003 05:50:28 -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 17 Jul 2003 05:50:28 -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, _AnyIsBound, _), 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.65
diff -u -r1.65 ml_unify_gen.m
--- compiler/ml_unify_gen.m 9 May 2003 00:45:05 -0000 1.65
+++ compiler/ml_unify_gen.m 17 Jul 2003 05:50:28 -0000
@@ -1902,7 +1902,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.101
diff -u -r1.101 mlds.m
--- compiler/mlds.m 16 May 2003 09:48:53 -0000 1.101
+++ compiler/mlds.m 17 Jul 2003 05:50:28 -0000
@@ -1691,7 +1691,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 17 Jul 2003 05:50:28 -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 17 Jul 2003 05:50:28 -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.85
diff -u -r1.85 module_qual.m
--- compiler/module_qual.m 15 Mar 2003 03:09:03 -0000 1.85
+++ compiler/module_qual.m 17 Jul 2003 05:50:28 -0000
@@ -939,6 +939,8 @@
qualify_type_spec_subst(Subst0, Subst, Info1, Info).
qualify_pragma(X at fact_table(_, _, _), X, Info, Info) --> [].
qualify_pragma(X at reserve_tag(_, _), X, Info, Info) --> [].
+qualify_pragma(X at any_is_bound(_, _), X, Info, Info) --> [].
+qualify_pragma(X at any_is_not_bound(_, _), X, Info, Info) --> [].
qualify_pragma(X at aditi(_, _), X, Info, Info) --> [].
qualify_pragma(X at base_relation(_, _), X, Info, Info) --> [].
qualify_pragma(X at aditi_index(_, _, _), X, Info, Info) --> [].
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.274
diff -u -r1.274 modules.m
--- compiler/modules.m 5 Jun 2003 04:16:20 -0000 1.274
+++ compiler/modules.m 17 Jul 2003 05:50:28 -0000
@@ -1530,6 +1530,8 @@
% `reserve_tag' must be in the interface iff the corresponding
% type definition is in the interface. This is checked in make_hlds.m.
pragma_allowed_in_interface(reserve_tag(_, _), yes).
+pragma_allowed_in_interface(any_is_bound(_, _), yes).
+pragma_allowed_in_interface(any_is_not_bound(_, _), yes).
pragma_allowed_in_interface(promise_pure(_, _), no).
pragma_allowed_in_interface(promise_semipure(_, _), no).
pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.413
diff -u -r1.413 options.m
--- compiler/options.m 26 May 2003 09:00:03 -0000 1.413
+++ compiler/options.m 17 Jul 2003 05:50:28 -0000
@@ -182,6 +182,7 @@
; infer_all
; type_inference_iteration_limit
; mode_inference_iteration_limit
+ ; default_any_is_bound
% Compilation Model options
; grade
@@ -816,7 +817,8 @@
infer_det - bool(yes),
infer_all - bool_special,
type_inference_iteration_limit - int(60),
- mode_inference_iteration_limit - int(30)
+ mode_inference_iteration_limit - int(30),
+ default_any_is_bound - bool(no)
]).
option_defaults_2(compilation_model_option, [
%
@@ -1450,6 +1452,7 @@
type_inference_iteration_limit).
long_option("mode-inference-iteration-limit",
mode_inference_iteration_limit).
+long_option("default-any-is-bound", default_any_is_bound).
% compilation model options
long_option("grade", grade).
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 17 Jul 2003 05:50:28 -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 17 Jul 2003 05:50:28 -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.93
diff -u -r1.93 prog_data.m
--- compiler/prog_data.m 8 May 2003 03:39:56 -0000 1.93
+++ compiler/prog_data.m 17 Jul 2003 05:50:28 -0000
@@ -296,6 +296,11 @@
; reserve_tag(sym_name, arity)
% Typename, Arity
+ ; any_is_bound(sym_name, arity)
+ % Typename, Arity
+
+ ; any_is_not_bound(sym_name, arity)
+ % Typename, Arity
%
% Aditi pragmas
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.59
diff -u -r1.59 prog_io_pragma.m
--- compiler/prog_io_pragma.m 26 May 2003 09:00:06 -0000 1.59
+++ compiler/prog_io_pragma.m 17 Jul 2003 05:50:28 -0000
@@ -888,6 +888,20 @@
Pragma = reserve_tag(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
+parse_pragma_type(ModuleName, "any_is_bound", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ parse_simple_type_pragma(ModuleName, "any_is_bound",
+ (pred(Name::in, Arity::in, Pragma::out) is det :-
+ Pragma = any_is_bound(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
+parse_pragma_type(ModuleName, "any_is_not_bound", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ parse_simple_type_pragma(ModuleName, "any_is_not_bound",
+ (pred(Name::in, Arity::in, Pragma::out) is det :-
+ Pragma = any_is_not_bound(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
(
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 17 Jul 2003 05:50:28 -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 17 Jul 2003 05:50:28 -0000
@@ -560,6 +560,8 @@
yes(yes(PredOrFunc) - Name / Arity)).
is_pred_pragma(fact_table(Name, Arity, _), yes(no - Name / Arity)).
is_pred_pragma(reserve_tag(_TypeName, _TypeArity), no).
+is_pred_pragma(any_is_bound(_TypeName, _TypeArity), no).
+is_pred_pragma(any_is_not_bound(_TypeName, _TypeArity), no).
is_pred_pragma(aditi(Name, Arity), yes(no - Name / Arity)).
is_pred_pragma(base_relation(Name, Arity), yes(no - Name / Arity)).
is_pred_pragma(aditi_index(Name, Arity, _), yes(no - Name / Arity)).
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.37
diff -u -r1.37 special_pred.m
--- compiler/special_pred.m 27 May 2003 05:57:21 -0000 1.37
+++ compiler/special_pred.m 17 Jul 2003 05:50:28 -0000
@@ -201,7 +201,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
@@ -212,14 +212,14 @@
(
type_body_has_user_defined_equality_pred(ModuleInfo, Body, _)
;
- Body = du_type(Ctors, _, _, _, _, _),
+ Ctors = Body ^ du_type_ctors,
list__member(Ctor, Ctors),
Ctor = ctor(ExistQTVars, _, _, _),
ExistQTVars \= []
).
can_generate_special_pred_clauses_for_type(TypeCtor, Body) :-
- Body \= abstract_type,
+ Body \= abstract_type(_),
\+ type_ctor_has_hand_defined_rtti(TypeCtor).
%-----------------------------------------------------------------------------%
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 17 Jul 2003 05:50:29 -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.12
diff -u -r1.12 switch_util.m
--- compiler/switch_util.m 26 May 2003 09:00:10 -0000 1.12
+++ compiler/switch_util.m 17 Jul 2003 05:50:29 -0000
@@ -322,7 +322,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
;
@@ -343,7 +343,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 17 Jul 2003 05:50:29 -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 17 Jul 2003 05:50:29 -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.40
diff -u -r1.40 type_ctor_info.m
--- compiler/type_ctor_info.m 29 May 2003 18:17:15 -0000 1.40
+++ compiler/type_ctor_info.m 17 Jul 2003 05:50:29 -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),
( 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(ModuleStr),
builtin_type_ctor(ModuleStr, 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 ->
Flags = 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.119
diff -u -r1.119 type_util.m
--- compiler/type_util.m 30 May 2003 14:43:45 -0000 1.119
+++ compiler/type_util.m 17 Jul 2003 05:50:29 -0000
@@ -79,6 +79,10 @@
:- 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__any_is_bound(module_info, (type)).
+:- mode type_util__any_is_bound(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
@@ -726,11 +730,58 @@
(
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__any_is_bound(ModuleInfo, Type) :-
+ type_util__any_is_bound_2(ModuleInfo, Type, AnyIsBound),
+ (
+ AnyIsBound = any_is_bound
+ ;
+ AnyIsBound = default,
+ module_info_globals(ModuleInfo, Globals),
+ globals__lookup_bool_option(Globals, default_any_is_bound, yes)
+ ).
+
+:- pred type_util__any_is_bound_2(module_info, (type), any_is_bound).
+:- mode type_util__any_is_bound_2(in, in, out) is semidet.
+
+type_util__any_is_bound_2(ModuleInfo, Type, AnyIsBound) :-
+ module_info_types(ModuleInfo, TypeTable),
+ type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
+ % type_to_ctor_and_args will fail for type variables. In that
+ % case we assume that `any' is not `bound' for the type.
+ ( map__search(TypeTable, TypeCtor, TypeDefn) ->
+ hlds_data__get_type_defn_body(TypeDefn, TypeBody),
+ type_body_any_is_bound(ModuleInfo, TypeBody, AnyIsBound)
+ ;
+ % Type table lookup will fail for builtin types such as `int/0'
+ % so we use the default value of any_is_bound.
+ AnyIsBound = default
+ ).
+
+ % Return the `any_is_bound' field for the type body.
+:- pred type_body_any_is_bound(module_info, hlds_type_body, any_is_bound).
+:- mode type_body_any_is_bound(in, in, out) is det.
+
+type_body_any_is_bound(ModuleInfo, TypeBody, AnyIsBound) :-
+ (
+ AnyIsBound = TypeBody ^ du_type_any_is_bound
+ ;
+ TypeBody = eqv_type(Type),
+ ( type_util__any_is_bound_2(ModuleInfo, Type, AnyIsBound0) ->
+ AnyIsBound = AnyIsBound0
+ ;
+ error("type_util__any_is_bound_2 failed")
+ )
+ ;
+ TypeBody = foreign_type(_, AnyIsBound)
+ ;
+ TypeBody = abstract_type(AnyIsBound)
+ ).
+
% 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
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.129
diff -u -r1.129 unify_gen.m
--- compiler/unify_gen.m 26 May 2003 09:00:12 -0000 1.129
+++ compiler/unify_gen.m 17 Jul 2003 05:50:29 -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.122
diff -u -r1.122 unify_proc.m
--- compiler/unify_proc.m 29 May 2003 18:17:16 -0000 1.122
+++ compiler/unify_proc.m 17 Jul 2003 05:50:29 -0000
@@ -293,7 +293,7 @@
module_info_types(ModuleInfo1, TypeTable),
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = abstract_type
+ TypeBody = abstract_type(_)
;
type_ctor_has_hand_defined_rtti(TypeCtor)
)
@@ -566,11 +566,12 @@
map__from_assoc_list([ConsId - single_functor],
ConsTagValues),
TypeBody = du_type([Ctor], ConsTagValues, IsEnum,
- UnifyPred, ReservedTag, IsForeign),
+ UnifyPred, ReservedTag, AnyIsBound, IsForeign),
UnifyPred = no,
IsEnum = no,
IsForeign = no,
ReservedTag = no,
+ AnyIsBound = default,
construct_type(TypeCtor, TupleArgTypes, Type),
term__context_init(Context)
@@ -735,7 +736,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
@@ -755,14 +757,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") }
)
).
@@ -869,7 +871,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
@@ -894,10 +897,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") }
)
).
@@ -917,7 +920,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,
@@ -948,11 +952,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") }
)
).
--
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