[m-dev.] for review: --no-special-preds
Zoltan Somogyi
zs at cs.mu.OZ.AU
Fri Mar 31 16:25:17 AEST 2000
Estimated hours taken: 30
Get the system to work with --no-special-preds, relying on RTTI interpretation
to perform unifications and comparisons, in almost all cases. The only thing
that doesn't work is comparisons involving types with user-defined equality;
the generated exception does not get propagated across MR_call_engine
boundaries properly.
compiler/make_hlds.m:
With --no-special-spreds, do not generate even declarations for
type-specific index and compare predicates. Generate declarations
and clauses for type-specific unify predicates, since we may need
them for unifications that are not (in,in). However, we prevent
the generation of code for the (in,in) case (i.e. mode 0) by pretending
that the unify predicate is pseudo_imported, even in the module
defining the type. There is one exception to this: for types with
user-defined equality, we do generate a proper __Unify__ predicate,
since this is the only convenient way to convert the specified
sym_name of the equality predicate into a pred_id and proc_id,
and a proper __Compare__ predicate, since this is the only convenient
way to generate the full type name for the error message at runtime
(due to polymorphism, the full type may not be known at compile time).
(Finding the pred_id may require resolving type overloading,
and finding the proc_id may require mode checking.)
compiler/simplify.m:
When converting complicated unifications to calls, call the generic
unify/2 and compare/3 predicates instead of the type-specific
__Unify__ and __Compare__ predicates, if the latter do not exist.
compiler/higher_order.m:
Do not specialize calls to the generic unify/2 and compare/3 predicates
to type-specific __Unify__ and __Compare__ predicates, if the latter
do not exist.
Also fix an old performance bug: for no_tag types wrapping builtins or
enumerations, we were only specializing compare in mode 0, when modes
0 through 3 have identical code (they differ only in uniqueness
requirements on the arguments). We were also not specializing
comparisons of builtins and enumerations here, leaving it to inlining.
In the absence of --special-preds, that doesn't work for enumerations,
since there is no compiler-generated comparison predicate to do
the inlining in. We therefore now perform both specializations.
comparison/polymorphism.m:
Fix a bug: the code for looking up the special preds for user defined
types was handling enums as builtins, which they are not.
compiler/type_ctor_info.m:
Even with --no-special-preds, the type has type-specific __Unify_
and __Compare__ predicates if it has user-defined equality. These
predicates must be, and now are, put into the type_ctor_info.
runtime/mercury_ho_call.c:
runtime/mercury_unify_compare_body.h:
Fix a bug that showed with --no-special-preds: the Mercury predicate
unify_2_0 cannot call the MR_generic_compare function to handle the
arguments of a function symbol, because comparison is not defined
on types with user-defined equality. Instead, we need to call the new
MR_generic_unify C function, which does work on such types.
Fix a bug that showed with --no-special-preds: the MR_succip register
has to be saved and restored across calls to MR_generic_unify, since
for types with user-defined equality, such calls involve a recursive
invocation of the Mercury engine.
Optimize the unification of du types by performing only one
functor_desc lookup instead of two, and failing as early as possible.
tests/hard_coded/user_defined_equality.{m,exp}:
To test comparisons on enums with user-defined equality, not just
unifications.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.62
diff -u -b -r1.62 higher_order.m
--- compiler/higher_order.m 2000/03/24 10:27:26 1.62
+++ compiler/higher_order.m 2000/03/30 07:43:30
@@ -926,11 +926,14 @@
error("higher_order.m: call expected")
),
module_info_pred_info(Module0, CalledPred, CalleePredInfo),
+ module_info_globals(Module0, Globals),
+ globals__lookup_bool_option(Globals, special_preds, HaveSpecialPreds),
(
% Look for calls to unify/2 and compare/3 which can
% be specialized.
specialize_special_pred(CalledPred, CalledProc,
- Args0, MaybeContext, Goal1, Info0, Info1)
+ Args0, MaybeContext, HaveSpecialPreds, Goal1,
+ Info0, Info1)
->
Goal = Goal1,
higher_order_info_update_changed_status(changed, Info1, Info)
@@ -1596,11 +1599,11 @@
% Succeed if the called pred is "unify", "compare" or "index" and
% is specializable, returning a specialized goal.
:- pred specialize_special_pred(pred_id::in, proc_id::in, list(prog_var)::in,
- maybe(call_unify_context)::in, hlds_goal_expr::out,
+ maybe(call_unify_context)::in, bool::in, hlds_goal_expr::out,
higher_order_info::in, higher_order_info::out) is semidet.
specialize_special_pred(CalledPred, CalledProc, Args,
- MaybeContext, Goal, Info0, Info) :-
+ MaybeContext, HaveSpecialPreds, Goal, Info0, Info) :-
Info0 = info(PredVars, B, C, D, E, ProcInfo0, ModuleInfo, H, I),
proc_info_vartypes(ProcInfo0, VarTypes),
module_info_pred_info(ModuleInfo, CalledPred, CalledPredInfo),
@@ -1623,21 +1626,77 @@
),
(
- SpecialId = unify,
+ % Look for unification or comparison applied directly to
+ % a builtin or atomic type. This needs to be done separately
+ % from the case for user-defined types, because we want to
+ % specialize such calls even if we are not generating any
+ % special preds.
+
+ specializeable_special_call(SpecialId, CalledProc),
type_is_atomic(SpecialPredType, ModuleInfo),
- proc_id_to_int(CalledProc, CalledProcInt),
- CalledProcInt = 0
+ \+ type_has_user_defined_equality_pred(ModuleInfo,
+ SpecialPredType, _)
->
- % Unifications of atomic types can be specialized
- % to simple_tests.
- SpecialPredArgs = [Arg1, Arg2],
+ (
+ SpecialId = unify,
+ SpecialPredArgs = [Arg1, Arg2]
+ ;
+ SpecialId = compare,
+ SpecialPredArgs = [_, Arg1, Arg2]
+ ),
+ (
+ SpecialId = unify,
in_mode(In),
Goal = unify(Arg1, var(Arg2), (In - In),
- simple_test(Arg1, Arg2), unify_context(explicit, [])),
+ simple_test(Arg1, Arg2),
+ unify_context(explicit, [])),
+ Info = Info0
+ ;
+ SpecialId = compare,
+ SpecialPredArgs = [ComparisonResult, _, _],
+ find_builtin_type_with_equivalent_compare(
+ ModuleInfo, SpecialPredType, CompareType,
+ NeedIntCast),
+ polymorphism__get_special_proc(CompareType,
+ SpecialId, ModuleInfo, SymName,
+ SpecialPredId, SpecialProcId),
+ (
+ NeedIntCast = no,
+ NewCallArgs = [ComparisonResult, Arg1, Arg2],
+ Goal = call(SpecialPredId, SpecialProcId,
+ NewCallArgs, not_builtin,
+ MaybeContext, SymName),
Info = Info0
;
+ NeedIntCast = yes,
+ generate_unsafe_type_cast(ModuleInfo,
+ CompareType, Arg1, CastArg1, CastGoal1,
+ ProcInfo0, ProcInfo1),
+ generate_unsafe_type_cast(ModuleInfo,
+ CompareType, Arg2, CastArg2, CastGoal2,
+ ProcInfo1, ProcInfo),
+ NewCallArgs = [ComparisonResult,
+ CastArg1, CastArg2],
+ Call = call(SpecialPredId, SpecialProcId,
+ NewCallArgs, not_builtin,
+ MaybeContext, SymName),
+ set__list_to_set([ComparisonResult,
+ Arg1, Arg2], NonLocals),
+ instmap_delta_from_assoc_list(
+ [ComparisonResult - ground(shared,no)],
+ InstMapDelta),
+ Detism = det,
+ goal_info_init(NonLocals, InstMapDelta,
+ Detism, GoalInfo),
+ Goal = conj([CastGoal1, CastGoal2,
+ Call - GoalInfo]),
+ Info = info(PredVars, B, C, D, E, ProcInfo,
+ ModuleInfo, H, I)
+ )
+ )
+ ;
% Look for unification or comparison applied to a no-tag type
- % wrapping a builtin type.
+ % wrapping a builtin or atomic type.
% This needs to be done to optimize all the map_lookups
% with keys of type `term__var/1' in the compiler.
% (:- type var(T) ---> var(int).)
@@ -1646,7 +1705,8 @@
% code for the comparison or in-in unification procedures
% for imported types, and unification and comparison will
% eventually be implemented in C code in the runtime system.
- ( SpecialId = unify ; SpecialId = compare ),
+
+ specializeable_special_call(SpecialId, CalledProc),
type_constructors(SpecialPredType, ModuleInfo, Constructors),
type_is_no_tag_type(Constructors, Constructor, WrappedType),
\+ type_has_user_defined_equality_pred(ModuleInfo,
@@ -1655,9 +1715,7 @@
% This could be done for non-atomic types, but it would
% be a bit more complicated because the type-info for
% the wrapped type would need to be extracted first.
- type_is_atomic(WrappedType, ModuleInfo),
- proc_id_to_int(CalledProc, CalledProcInt),
- CalledProcInt = 0
+ type_is_atomic(WrappedType, ModuleInfo)
->
(
SpecialId = unify,
@@ -1669,7 +1727,7 @@
unwrap_no_tag_arg(WrappedType, Constructor, Arg1,
UnwrappedArg1, ExtractGoal1, ProcInfo0, ProcInfo1),
unwrap_no_tag_arg(WrappedType, Constructor, Arg2,
- UnwrappedArg2, ExtractGoal2, ProcInfo1, ProcInfo),
+ UnwrappedArg2, ExtractGoal2, ProcInfo1, ProcInfo2),
set__list_to_set([UnwrappedArg1, UnwrappedArg2], NonLocals0),
(
SpecialId = unify,
@@ -1680,31 +1738,68 @@
SpecialGoal = unify(UnwrappedArg1, var(UnwrappedArg2),
(In - In),
simple_test(UnwrappedArg1, UnwrappedArg2),
- unify_context(explicit, []))
+ unify_context(explicit, [])),
+ goal_info_init(NonLocals, InstMapDelta, Detism,
+ GoalInfo),
+ Goal = conj([ExtractGoal1, ExtractGoal2,
+ SpecialGoal - GoalInfo]),
+ Info = info(PredVars, B, C, D, E, ProcInfo2,
+ ModuleInfo, H, I)
;
SpecialId = compare,
SpecialPredArgs = [ComparisonResult, _, _],
set__insert(NonLocals0, ComparisonResult, NonLocals),
- NewCallArgs = [ComparisonResult,
- UnwrappedArg1, UnwrappedArg2],
instmap_delta_from_assoc_list(
[ComparisonResult - ground(shared, no)],
InstMapDelta),
Detism = det,
% Build a new call with the unwrapped arguments.
- polymorphism__get_special_proc(WrappedType,
+ find_builtin_type_with_equivalent_compare(
+ ModuleInfo, WrappedType, CompareType,
+ NeedIntCast),
+ polymorphism__get_special_proc(CompareType,
SpecialId, ModuleInfo, SymName,
SpecialPredId, SpecialProcId),
- SpecialGoal = call(SpecialPredId, SpecialProcId,
- NewCallArgs, not_builtin,
- MaybeContext, SymName)
- ),
- goal_info_init(NonLocals, InstMapDelta, Detism, GoalInfo),
-
+ (
+ NeedIntCast = no,
+ NewCallArgs = [ComparisonResult,
+ UnwrappedArg1, UnwrappedArg2],
+ SpecialGoal = call(SpecialPredId,
+ SpecialProcId, NewCallArgs,
+ not_builtin, MaybeContext, SymName),
+ goal_info_init(NonLocals, InstMapDelta, Detism,
+ GoalInfo),
Goal = conj([ExtractGoal1, ExtractGoal2,
+ SpecialGoal - GoalInfo]),
+ Info = info(PredVars, B, C, D, E, ProcInfo2,
+ ModuleInfo, H, I)
+ ;
+ NeedIntCast = yes,
+ generate_unsafe_type_cast(ModuleInfo,
+ CompareType, UnwrappedArg1, CastArg1,
+ CastGoal1, ProcInfo2, ProcInfo3),
+ generate_unsafe_type_cast(ModuleInfo,
+ CompareType, UnwrappedArg2, CastArg2,
+ CastGoal2, ProcInfo3, ProcInfo4),
+ NewCallArgs = [ComparisonResult,
+ CastArg1, CastArg2],
+ SpecialGoal = call(SpecialPredId,
+ SpecialProcId, NewCallArgs,
+ not_builtin, MaybeContext, SymName),
+ goal_info_init(NonLocals, InstMapDelta, Detism,
+ GoalInfo),
+ Goal = conj([ExtractGoal1, CastGoal1,
+ ExtractGoal2, CastGoal2,
SpecialGoal - GoalInfo]),
- Info = info(PredVars, B, C, D, E, ProcInfo, ModuleInfo, H, I)
+ Info = info(PredVars, B, C, D, E, ProcInfo4,
+ ModuleInfo, H, I)
+ )
+ )
;
+ % We can only specialize unifications and comparisons
+ % to call the type-specific unify or compare predicate
+ % if we are generating such predicates.
+ HaveSpecialPreds = yes,
polymorphism__get_special_proc(SpecialPredType, SpecialId,
ModuleInfo, SymName, SpecialPredId, SpecialProcId),
( type_is_higher_order(SpecialPredType, _, _, _) ->
@@ -1719,6 +1814,84 @@
Info = Info0
).
+:- pred find_builtin_type_with_equivalent_compare(module_info::in,
+ (type)::in, (type)::out, bool::out) is det.
+
+find_builtin_type_with_equivalent_compare(ModuleInfo, Type, EqvType,
+ NeedIntCast) :-
+ classify_type(Type, ModuleInfo, TypeCategory),
+ (
+ TypeCategory = int_type,
+ EqvType = Type,
+ NeedIntCast = no
+ ;
+ TypeCategory = char_type,
+ EqvType = Type,
+ NeedIntCast = no
+ ;
+ TypeCategory = str_type,
+ EqvType = Type,
+ NeedIntCast = no
+ ;
+ TypeCategory = float_type,
+ EqvType = Type,
+ NeedIntCast = no
+ ;
+ TypeCategory = pred_type,
+ error("pred type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = enum_type,
+ construct_type(unqualified("int") - 0, [], EqvType),
+ NeedIntCast = yes
+ ;
+ TypeCategory = polymorphic_type,
+ error("poly type in find_builtin_type_with_equivalent_compare")
+ ;
+ TypeCategory = user_type,
+ error("user type in find_builtin_type_with_equivalent_compare")
+ ).
+
+:- pred specializeable_special_call(special_pred_id::in, proc_id::in)
+ is semidet.
+
+specializeable_special_call(SpecialId, CalledProc) :-
+ proc_id_to_int(CalledProc, CalledProcInt),
+ (
+ SpecialId = unify,
+ CalledProcInt = 0
+ ;
+ % compare has four procedures numbered 0 to 3 with identical
+ % behavior, whose two input arguments' modes are all the
+ % possible combinations of (ui,in) with (ui,in).
+ SpecialId = compare,
+ CalledProcInt =< 3
+ ).
+
+:- pred generate_unsafe_type_cast(module_info::in, (type)::in,
+ prog_var::in, prog_var::out, hlds_goal::out,
+ proc_info::in, proc_info::out) is det.
+
+generate_unsafe_type_cast(ModuleInfo, ToType, Arg, CastArg, Goal,
+ ProcInfo0, ProcInfo) :-
+ module_info_get_predicate_table(ModuleInfo, PredicateTable),
+ mercury_private_builtin_module(MercuryBuiltin),
+ (
+ predicate_table_search_pred_m_n_a(PredicateTable,
+ MercuryBuiltin, "unsafe_type_cast", 2, [PredIdPrime])
+ ->
+ PredId = PredIdPrime
+ ;
+ error("generate_unsafe_type_cast: pred table lookup failed")
+ ),
+ proc_id_to_int(ProcId, 0),
+ proc_info_create_var_from_type(ProcInfo0, ToType, CastArg, ProcInfo),
+ set__list_to_set([Arg, CastArg], NonLocals),
+ instmap_delta_from_assoc_list([CastArg - ground(shared, no)],
+ InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, GoalInfo),
+ Goal = call(PredId, ProcId, [Arg, CastArg], not_builtin,
+ no, qualified(MercuryBuiltin, "unsafe_type_cast")) - GoalInfo.
+
:- pred unwrap_no_tag_arg((type)::in, sym_name::in, prog_var::in,
prog_var::out, hlds_goal::out, proc_info::in, proc_info::out) is det.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.328
diff -u -b -r1.328 make_hlds.m
--- compiler/make_hlds.m 2000/03/27 05:07:36 1.328
+++ compiler/make_hlds.m 2000/03/30 05:26:02
@@ -2744,7 +2744,7 @@
)
->
add_special_pred_decl_list(SpecialPredIds, Module0, TVarSet,
- Type, TypeId, Context, Status, Module)
+ Type, TypeId, Body, Context, Status, Module)
;
add_special_pred_list(SpecialPredIds, Module0, TVarSet,
Type, TypeId, Body, Context, Status, Module)
@@ -2772,15 +2772,42 @@
Context, Status0, Module) :-
module_info_globals(Module0, Globals),
globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
- ( GenSpecialPreds = yes ->
+ (
+ GenSpecialPreds = yes,
add_special_pred_for_real(SpecialPredId, Module0, TVarSet,
Type, TypeId, TypeBody, Context, Status0, Module)
- ; SpecialPredId = unify ->
- add_special_pred_for_real(SpecialPredId, Module0, TVarSet,
- Type, TypeId, TypeBody, Context, pseudo_imported,
- Module)
;
+ GenSpecialPreds = no,
+ (
+ SpecialPredId = unify,
+ add_special_pred_unify_status(TypeBody, Status0,
+ Status),
+ add_special_pred_for_real(SpecialPredId, Module0,
+ TVarSet, Type, TypeId, TypeBody, Context,
+ Status, Module)
+ ;
+ SpecialPredId = index,
Module = Module0
+ ;
+ SpecialPredId = compare,
+ ( TypeBody = du_type(_, _, _, yes(_)) ->
+ % The compiler generated comparison
+ % procedure prints an error message,
+ % since comparisons of types with
+ % user-defined equality are not
+ % allowed. We get the runtime system
+ % invoke this procedure instead of
+ % printing the error message itself,
+ % because it is easier to generate
+ % a good error message in Mercury code
+ % than in C code.
+ add_special_pred_for_real(SpecialPredId,
+ Module0, TVarSet, Type, TypeId,
+ TypeBody, Context, Status0, Module)
+ ;
+ Module = Module0
+ )
+ )
).
:- pred add_special_pred_for_real(special_pred_id,
@@ -2806,7 +2833,25 @@
map__lookup(Preds0, PredId, PredInfo0),
% if the type was imported, then the special preds for that
% type should be imported too
- ( (Status = imported(_) ; Status = pseudo_imported) ->
+ (
+ (Status = imported(_) ; Status = pseudo_imported)
+ ->
+ pred_info_set_import_status(PredInfo0, Status, PredInfo1)
+ ;
+ TypeBody = du_type(_, _, _, yes(_)),
+ pred_info_import_status(PredInfo0, OldStatus),
+ OldStatus = pseudo_imported,
+ status_is_imported(Status, no)
+ ->
+ % We can only get here with --no-special-preds if the old
+ % status is from an abstract declaration of the type.
+ % Since the compiler did not then know that the type definition
+ % will specify a user-defined equality predicate, it set up
+ % the status as pseudo_imported in order to prevent the
+ % generation of code for mode 0 of the __Unify__ predicate
+ % for the type. However, for types with user-defined equality,
+ % we *do* want to generate code for mode 0 of __Unify__,
+ % so we fix the status.
pred_info_set_import_status(PredInfo0, Status, PredInfo1)
;
PredInfo1 = PredInfo0
@@ -2818,24 +2863,24 @@
module_info_set_preds(Module1, Preds, Module).
:- pred add_special_pred_decl_list(list(special_pred_id),
- module_info, tvarset, type, type_id,
+ module_info, tvarset, type, type_id, hlds_type_body,
prog_context, import_status, module_info).
-:- mode add_special_pred_decl_list(in, in, in, in, in, in, in, out) is det.
+:- mode add_special_pred_decl_list(in, in, in, in, in, in, in, in, out) is det.
-add_special_pred_decl_list([], Module, _, _, _, _, _, Module).
+add_special_pred_decl_list([], Module, _, _, _, _, _, _, Module).
add_special_pred_decl_list([SpecialPredId | SpecialPredIds], Module0,
- TVarSet, Type, TypeId, Context, Status, Module) :-
+ TVarSet, Type, TypeId, TypeBody, Context, Status, Module) :-
add_special_pred_decl(SpecialPredId, Module0,
- TVarSet, Type, TypeId, Context, Status, Module1),
+ TVarSet, Type, TypeId, TypeBody, Context, Status, Module1),
add_special_pred_decl_list(SpecialPredIds, Module1,
- TVarSet, Type, TypeId, Context, Status, Module).
+ TVarSet, Type, TypeId, TypeBody, Context, Status, Module).
:- pred add_special_pred_decl(special_pred_id,
- module_info, tvarset, type, type_id, prog_context,
- import_status, module_info).
-:- mode add_special_pred_decl(in, in, in, in, in, in, in, out) is det.
+ module_info, tvarset, type, type_id, hlds_type_body,
+ prog_context, import_status, module_info).
+:- mode add_special_pred_decl(in, in, in, in, in, in, in, in, out) is det.
-add_special_pred_decl(SpecialPredId, Module0, TVarSet, Type, TypeId,
+add_special_pred_decl(SpecialPredId, Module0, TVarSet, Type, TypeId, TypeBody,
Context, Status0, Module) :-
module_info_globals(Module0, Globals),
globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
@@ -2843,9 +2888,9 @@
add_special_pred_decl_for_real(SpecialPredId, Module0,
TVarSet, Type, TypeId, Context, Status0, Module)
; SpecialPredId = unify ->
+ add_special_pred_unify_status(TypeBody, Status0, Status),
add_special_pred_decl_for_real(SpecialPredId, Module0,
- TVarSet, Type, TypeId, Context, pseudo_imported,
- Module)
+ TVarSet, Type, TypeId, Context, Status, Module)
;
Module = Module0
).
@@ -2890,6 +2935,25 @@
map__set(SpecialPredMap0, SpecialPredId - TypeId, PredId,
SpecialPredMap),
module_info_set_special_pred_map(Module1, SpecialPredMap, Module).
+
+:- pred add_special_pred_unify_status(hlds_type_body::in, import_status::in,
+ import_status::out) is det.
+
+add_special_pred_unify_status(TypeBody, Status0, Status) :-
+ ( TypeBody = du_type(_, _, _, yes(_)) ->
+ % If the type has user-defined equality,
+ % then we create a real __Unify__ predicate
+ % for it, whose body calls the user-specified
+ % predicate. The compiler's usual type checking
+ % algorithm will handle any necessary
+ % disambiguation from predicates with the same
+ % name but different argument types, and the
+ % usual mode checking algorithm will select
+ % the right mode of the chosen predicate.
+ Status = Status0
+ ;
+ Status = pseudo_imported
+ ).
:- pred adjust_special_pred_status(import_status, special_pred_id,
import_status).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.182
diff -u -b -r1.182 polymorphism.m
--- compiler/polymorphism.m 2000/03/24 10:27:31 1.182
+++ compiler/polymorphism.m 2000/03/31 01:31:04
@@ -2647,7 +2647,7 @@
polymorphism__get_special_proc(Type, SpecialPredId, ModuleInfo,
PredName, PredId, ProcId) :-
classify_type(Type, ModuleInfo, TypeCategory),
- ( TypeCategory = user_type ->
+ ( ( TypeCategory = user_type ; TypeCategory = enum_type ) ->
module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
( type_to_type_id(Type, TypeId, _TypeArgs) ->
map__search(SpecialPredMap, SpecialPredId - TypeId,
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.76
diff -u -b -r1.76 simplify.m
--- compiler/simplify.m 2000/02/25 08:45:54 1.76
+++ compiler/simplify.m 2000/03/27 17:56:00
@@ -1136,31 +1136,9 @@
% are being unified.
%
simplify__type_info_locn(TypeVar, TypeInfoVar, ExtraGoals),
- { ArgVars = [TypeInfoVar, XVar, YVar] },
+ { simplify__call_generic_unify(TypeInfoVar, XVar, YVar,
+ ModuleInfo, Context, GoalInfo0, Call) }
- { module_info_get_predicate_table(ModuleInfo,
- PredicateTable) },
- { mercury_public_builtin_module(MercuryBuiltin) },
- { predicate_table_search_pred_m_n_a(PredicateTable,
- MercuryBuiltin, "unify", 2, [CallPredId])
- ->
- PredId = CallPredId
- ;
- error("simplify.m: can't find `builtin:unify/2'")
- },
- % Note: the mode for polymorphic unifications
- % should be `in, in'.
- % (This should have been checked by mode analysis.)
- { hlds_pred__in_in_unification_proc_id(ProcId) },
-
- { SymName = unqualified("unify") },
- { code_util__builtin_state(ModuleInfo, PredId, ProcId,
- BuiltinState) },
- { CallContext = call_unify_context(XVar, var(YVar), Context) },
- { Call = call(PredId, ProcId, ArgVars,
- BuiltinState, yes(CallContext), SymName)
- - GoalInfo0 }
-
; { type_is_higher_order(Type, _, _, _) } ->
%
% convert higher-order unifications into calls to
@@ -1188,45 +1166,100 @@
simplify__goal_2(Call0, GoalInfo0, Call1, GoalInfo),
{ Call = Call1 - GoalInfo },
{ ExtraGoals = [] }
-
- ; { type_to_type_id(Type, TypeId, TypeArgs) } ->
+ ;
+ { type_to_type_id(Type, TypeIdPrime, TypeArgsPrime) ->
+ TypeId = TypeIdPrime,
+ TypeArgs = TypeArgsPrime
+ ;
+ error("simplify: type_to_type_id failed")
+ },
+ { determinism_components(Det, CanFail, at_most_one) },
+ { unify_proc__lookup_mode_num(ModuleInfo, TypeId, UniMode, Det,
+ ProcId) },
+ { module_info_globals(ModuleInfo, Globals) },
+ { globals__lookup_bool_option(Globals, special_preds,
+ SpecialPreds) },
+ (
+ { SpecialPreds = no },
+ { proc_id_to_int(ProcId, ProcIdInt) },
+ { ProcIdInt = 0 }
+ ->
+ simplify__make_type_info_vars([Type], TypeInfoVars,
+ ExtraGoals),
+ { TypeInfoVars = [TypeInfoVarPrime] ->
+ TypeInfoVar = TypeInfoVarPrime
+ ;
+ error("simplify__process_compl_unify: more than one typeinfo for one type var")
+ },
+ { simplify__call_generic_unify(TypeInfoVar, XVar, YVar,
+ ModuleInfo, Context, GoalInfo0, Call) }
+ ;
%
% Convert other complicated unifications into
% calls to specific unification predicates,
% inserting extra typeinfo arguments if necessary.
%
- % generate code to construct the new type_info arguments
- simplify__make_type_info_vars(TypeArgs, TypeInfoVars,
- ExtraGoals),
-
- % create the new call goal
- { list__append(TypeInfoVars, [XVar, YVar], ArgVars) },
- { module_info_get_special_pred_map(ModuleInfo,
- SpecialPredMap) },
- { map__lookup(SpecialPredMap, unify - TypeId, PredId) },
- { determinism_components(Det, CanFail, at_most_one) },
- { unify_proc__lookup_mode_num(ModuleInfo, TypeId,
- UniMode, Det, ProcId) },
- { SymName = unqualified("__Unify__") },
- { CallContext = call_unify_context(XVar, var(YVar), Context) },
- { Call0 = call(PredId, ProcId, ArgVars, not_builtin,
- yes(CallContext), SymName) },
-
- % add the extra type_info vars to the nonlocals for the call
- { goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
- { set__insert_list(NonLocals0, TypeInfoVars, NonLocals) },
- { goal_info_set_nonlocals(GoalInfo0, NonLocals,
- CallGoalInfo0) },
-
- % recursively simplify the call goal
- simplify__goal_2(Call0, CallGoalInfo0, Call1, CallGoalInfo1),
+ simplify__make_type_info_vars(TypeArgs,
+ TypeInfoVars, ExtraGoals),
+ { simplify__call_specific_unify(TypeId, TypeInfoVars,
+ XVar, YVar, ProcId, ModuleInfo, Context,
+ GoalInfo0, Call0, CallGoalInfo0) },
+ simplify__goal_2(Call0, CallGoalInfo0,
+ Call1, CallGoalInfo1),
{ Call = Call1 - CallGoalInfo1 }
- ;
- { error("simplify: type_to_type_id failed") }
+ )
),
{ list__append(ExtraGoals, [Call], ConjList) },
{ conj_list_to_goal(ConjList, GoalInfo0, Goal) }.
+
+:- pred simplify__call_generic_unify(prog_var::in, prog_var::in, prog_var::in,
+ module_info::in, unify_context::in, hlds_goal_info::in, hlds_goal::out)
+ is det.
+
+simplify__call_generic_unify(TypeInfoVar, XVar, YVar, ModuleInfo, Context,
+ GoalInfo, Call) :-
+ ArgVars = [TypeInfoVar, XVar, YVar],
+ module_info_get_predicate_table(ModuleInfo, PredicateTable),
+ mercury_public_builtin_module(MercuryBuiltin),
+ ( predicate_table_search_pred_m_n_a(PredicateTable,
+ MercuryBuiltin, "unify", 2, [CallPredId])
+ ->
+ PredId = CallPredId
+ ;
+ error("simplify.m: can't find `builtin:unify/2'")
+ ),
+ % Note: the mode for polymorphic unifications
+ % should be `in, in'.
+ % (This should have been checked by mode analysis.)
+ hlds_pred__in_in_unification_proc_id(ProcId),
+
+ SymName = unqualified("unify"),
+ code_util__builtin_state(ModuleInfo, PredId, ProcId, BuiltinState),
+ CallContext = call_unify_context(XVar, var(YVar), Context),
+ Call = call(PredId, ProcId, ArgVars, BuiltinState, yes(CallContext),
+ SymName) - GoalInfo.
+
+:- pred simplify__call_specific_unify(type_id::in, list(prog_var)::in,
+ prog_var::in, prog_var::in, proc_id::in,
+ module_info::in, unify_context::in, hlds_goal_info::in,
+ hlds_goal_expr::out, hlds_goal_info::out) is det.
+
+simplify__call_specific_unify(TypeId, TypeInfoVars, XVar, YVar, ProcId,
+ ModuleInfo, Context, GoalInfo0, CallExpr, CallGoalInfo) :-
+ % create the new call goal
+ list__append(TypeInfoVars, [XVar, YVar], ArgVars),
+ module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
+ map__lookup(SpecialPredMap, unify - TypeId, PredId),
+ SymName = unqualified("__Unify__"),
+ CallContext = call_unify_context(XVar, var(YVar), Context),
+ CallExpr = call(PredId, ProcId, ArgVars, not_builtin,
+ yes(CallContext), SymName),
+
+ % add the extra type_info vars to the nonlocals for the call
+ goal_info_get_nonlocals(GoalInfo0, NonLocals0),
+ set__insert_list(NonLocals0, TypeInfoVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, CallGoalInfo).
:- pred simplify__make_type_info_vars(list(type)::in, list(prog_var)::out,
list(hlds_goal)::out, simplify_info::in, simplify_info::out) is det.
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.2
diff -u -b -r1.2 type_ctor_info.m
--- compiler/type_ctor_info.m 2000/03/24 02:16:19 1.2
+++ compiler/type_ctor_info.m 2000/03/30 05:33:34
@@ -120,10 +120,10 @@
ModuleName, ModuleInfo, TypeCtorGenInfo) :-
hlds_data__get_type_defn_status(TypeDefn, Status),
module_info_globals(ModuleInfo, Globals),
+ module_info_get_special_pred_map(ModuleInfo, SpecMap),
globals__lookup_bool_option(Globals, special_preds, SpecialPreds),
(
SpecialPreds = yes,
- module_info_get_special_pred_map(ModuleInfo, SpecMap),
map__lookup(SpecMap, unify - TypeId, UnifyPredId),
special_pred_mode_num(unify, UnifyProcInt),
@@ -141,9 +141,24 @@
MaybeCompare = yes(proc(ComparePredId, CompareProcId))
;
SpecialPreds = no,
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = du_type(_, _, _, yes(_UserDefinedEquality)) ->
+ map__lookup(SpecMap, unify - TypeId, UnifyPredId),
+ special_pred_mode_num(unify, UnifyProcInt),
+ proc_id_to_int(UnifyProcId, UnifyProcInt),
+ MaybeUnify = yes(proc(UnifyPredId, UnifyProcId)),
+
+ MaybeIndex = no,
+
+ map__lookup(SpecMap, compare - TypeId, ComparePredId),
+ special_pred_mode_num(compare, CompareProcInt),
+ proc_id_to_int(CompareProcId, CompareProcInt),
+ MaybeCompare = yes(proc(ComparePredId, CompareProcId))
+ ;
MaybeUnify = no,
MaybeIndex = no,
MaybeCompare = no
+ )
),
TypeCtorGenInfo = type_ctor_gen_info(TypeId, ModuleName,
TypeName, TypeArity, Status, TypeDefn,
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing library
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.31
diff -u -b -r1.31 mercury_ho_call.c
--- runtime/mercury_ho_call.c 2000/03/24 10:27:48 1.31
+++ runtime/mercury_ho_call.c 2000/03/30 08:04:36
@@ -23,6 +23,7 @@
#include "mercury_ho_call.h"
static Word MR_generic_compare(MR_TypeInfo type_info, Word x, Word y);
+static Word MR_generic_unify(MR_TypeInfo type_info, Word x, Word y);
/*
** The called closure may contain only input arguments. The extra arguments
@@ -182,18 +183,21 @@
#define DECLARE_LOCALS \
MR_TypeCtorInfo type_ctor_info; \
MR_TypeInfo type_info; \
- Word x, y;
+ Word x, y; \
+ Code *saved_succip;
#define initialize() \
do { \
type_info = (MR_TypeInfo) r1; \
x = r2; \
y = r3; \
+ saved_succip = MR_succip; \
} while(0)
#define return_answer(answer) \
do { \
r1 = (answer); \
+ MR_succip = saved_succip; \
proceed(); \
} while(0)
@@ -396,18 +400,21 @@
#define DECLARE_LOCALS \
MR_TypeCtorInfo type_ctor_info; \
MR_TypeInfo type_info; \
- Word x, y;
+ Word x, y; \
+ Code *saved_succip;
#define initialize() \
do { \
type_info = (MR_TypeInfo) r1; \
x = r2; \
y = r3; \
+ saved_succip = MR_succip; \
} while(0)
#define return_answer(answer) \
do { \
r1 = (answer); \
+ MR_succip = saved_succip; \
proceed(); \
} while(0)
@@ -434,6 +441,46 @@
}
END_MODULE
+
+static Word
+MR_generic_unify(MR_TypeInfo type_info, Word x, Word y)
+{
+
+#define DECLARE_LOCALS \
+ MR_TypeCtorInfo type_ctor_info;
+
+#define initialize() \
+ do { \
+ (void) 0; /* do nothing */ \
+ } while(0)
+
+#define return_answer(answer) \
+ return (answer)
+
+#define tailcall_user_pred() \
+ do { \
+ save_transient_registers(); \
+ (void) MR_call_engine(type_ctor_info->unify_pred, FALSE);\
+ restore_transient_registers(); \
+ return (r1); \
+ } while (0)
+
+#define start_label unify_func_start
+#define call_user_code_label call_unify_in_func
+#define ctor_rep_stats_array MR_ctor_rep_unify
+#define attempt_msg "attempt to unify "
+
+#include "mercury_unify_compare_body.h"
+
+#undef DECLARE_LOCALS
+#undef initialize
+#undef return_answer
+#undef tailcall_user_pred
+#undef start_label
+#undef call_user_code_label
+#undef ctor_rep_stats_array
+#undef attempt_msg
+}
static Word
MR_generic_compare(MR_TypeInfo type_info, Word x, Word y)
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.1
diff -u -b -r1.1 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h 2000/03/24 10:27:53 1.1
+++ runtime/mercury_unify_compare_body.h 2000/03/29 16:03:48
@@ -6,10 +6,11 @@
/*
** This file contains a piece of code that is included by mercury_ho_call.c
-** three times:
+** four times:
**
** - as the body of the mercury__unify_2_0 Mercury procedure,
** - as the body of the mercury__compare_3_3 Mercury procedure, and
+** - as the body of the MR_generic_unify C function.
** - as the body of the MR_generic_compare C function.
**
** The inclusions are surrounded by #defines and #undefs of the macros
@@ -21,14 +22,20 @@
** its result slightly differently.
**
** The reason why there is both a Mercury procedure and a C function for
-** comparisons is that the Mercury procedure needs a mechanism that allows it
-** to compare each argument of a function symbol, and doing it with a loop body
-** that calls C function is significantly easier to program, and probably
-** more efficient, than using recursion in Mercury. The Mercury procedure and
-** C function share code because they implement the same task.
+** unifications and comparisons is that the Mercury procedure needs a
+** mechanism that allows it to unify or compare each argument of a function
+** symbol, and doing it with a loop body that calls C function is
+** significantly easier to program, and probably more efficient, than
+** using recursion in Mercury. The Mercury procedure and C function share code
+** because they implement the same task.
**
-** There is no C function for unification, since the C function for comparison
-** is sufficient for programming the Mercury procedure for unification.
+** We need separate C functions for unifications and comparison because
+** with --no-special-preds, a type with user-defined equality has an
+** a non-NULL unify_pred field in its type_ctor_info but a NULL compare_pred
+** field. While in principle unification is a special case of comparison,
+** we cannot implement unifications by comparisons for such types:
+** they support unifications but not comparisons. Since we cannot do it
+** for such types, it is simplest not to do it for any types.
*/
DECLARE_LOCALS
@@ -76,8 +83,19 @@
case MR_TYPECTOR_REP_DU:
{
+ const MR_DuFunctorDesc *functor_desc;
+#ifdef select_compare_code
const MR_DuFunctorDesc *x_functor_desc;
const MR_DuFunctorDesc *y_functor_desc;
+ MR_DuPtagLayout *x_ptaglayout;
+ MR_DuPtagLayout *y_ptaglayout;
+#else
+ Word x_ptag;
+ Word y_ptag;
+ Word x_sectag;
+ Word y_sectag;
+ MR_DuPtagLayout *ptaglayout;
+#endif
Word *x_data_value;
Word *y_data_value;
const MR_DuExistInfo *exist_info;
@@ -86,6 +104,8 @@
int arity;
int i;
+#ifdef select_compare_code
+
#define MR_find_du_functor_desc(data, data_value, functor_desc) \
do { \
MR_DuPtagLayout *ptaglayout; \
@@ -119,7 +139,6 @@
if (x_functor_desc->MR_du_functor_ordinal !=
y_functor_desc->MR_du_functor_ordinal)
{
-#ifdef select_compare_code
if (x_functor_desc->MR_du_functor_ordinal <
y_functor_desc->MR_du_functor_ordinal)
{
@@ -127,13 +146,51 @@
} else {
return_answer(MR_COMPARE_GREATER);
}
+ }
+
+ functor_desc = x_functor_desc;
#else
+ x_ptag = MR_tag(x);
+ y_ptag = MR_tag(y);
+
+ if (x_ptag != y_ptag) {
return_answer(FALSE);
-#endif
+ }
+
+ ptaglayout = &type_ctor_info->type_layout.layout_du[x_ptag];
+ x_data_value = (Word *) MR_body(x, x_ptag);
+ y_data_value = (Word *) MR_body(y, y_ptag);
+
+ switch (ptaglayout->MR_sectag_locn) {
+ case MR_SECTAG_LOCAL:
+ x_sectag = MR_unmkbody(x_data_value);
+ y_sectag = MR_unmkbody(y_data_value);
+
+ if (x_sectag != y_sectag) {
+ return_answer(FALSE);
+ }
+
+ break;
+
+ case MR_SECTAG_REMOTE:
+ x_sectag = x_data_value[0];
+ y_sectag = y_data_value[0];
+
+ if (x_sectag != y_sectag) {
+ return_answer(FALSE);
}
- /* x_functor_desc and y_functor_desc must be the same */
- if (x_functor_desc->MR_du_functor_sectag_locn ==
+ break;
+
+ case MR_SECTAG_NONE:
+ x_sectag = 0;
+ break;
+ }
+
+ functor_desc = ptaglayout->MR_sectag_alternatives[x_sectag];
+#endif
+
+ if (functor_desc->MR_du_functor_sectag_locn ==
MR_SECTAG_REMOTE)
{
cur_slot = 1;
@@ -141,8 +198,8 @@
cur_slot = 0;
}
- arity = x_functor_desc->MR_du_functor_orig_arity;
- exist_info = x_functor_desc->MR_du_functor_exist_info;
+ arity = functor_desc->MR_du_functor_orig_arity;
+ exist_info = functor_desc->MR_du_functor_exist_info;
if (exist_info != NULL) {
int num_ti_plain;
@@ -187,24 +244,28 @@
for (i = 0; i < arity; i++) {
MR_TypeInfo arg_type_info;
- if (MR_arg_type_may_contain_var(x_functor_desc, i)) {
+ if (MR_arg_type_may_contain_var(functor_desc, i)) {
arg_type_info = MR_create_type_info_maybe_existq(
MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(type_info),
- x_functor_desc->MR_du_functor_arg_types[i],
- x_data_value, x_functor_desc);
+ functor_desc->MR_du_functor_arg_types[i],
+ x_data_value, functor_desc);
} else {
arg_type_info = (MR_TypeInfo)
- x_functor_desc->MR_du_functor_arg_types[i];
+ functor_desc->MR_du_functor_arg_types[i];
}
+#ifdef select_compare_code
result = MR_generic_compare(arg_type_info,
x_data_value[cur_slot], y_data_value[cur_slot]);
if (result != MR_COMPARE_EQUAL) {
-#ifdef select_compare_code
return_answer(result);
+ }
#else
+ result = MR_generic_unify(arg_type_info,
+ x_data_value[cur_slot], y_data_value[cur_slot]);
+ if (! result) {
return_answer(FALSE);
-#endif
}
+#endif
cur_slot++;
}
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/user_defined_equality.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/user_defined_equality.exp,v
retrieving revision 1.1
diff -u -b -r1.1 user_defined_equality.exp
--- tests/hard_coded/user_defined_equality.exp 1999/10/26 15:01:47 1.1
+++ tests/hard_coded/user_defined_equality.exp 2000/03/31 01:34:29
@@ -1 +1,3 @@
yes
+threw exception: univ(software_error("call to compare/3 for non-canonical type `user_defined_equality:foo\'") : require:software_error)
+threw exception: univ(software_error("call to compare/3 for non-canonical type `user_defined_equality:foo\'") : require:software_error)
Index: tests/hard_coded/user_defined_equality.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/user_defined_equality.m,v
retrieving revision 1.1
diff -u -b -r1.1 user_defined_equality.m
--- tests/hard_coded/user_defined_equality.m 1999/10/26 15:01:47 1.1
+++ tests/hard_coded/user_defined_equality.m 2000/03/31 01:36:28
@@ -1,14 +1,25 @@
-% This is a regression test;
-% the Mercury compiler of 26/10/1999 failed this test.
+% This is a regression test.
+%
+% The Mercury compiler of 26/10/1999 failed the first part of this test
+% (the part concerned with the implied mode of append).
+%
+% The Mercury compiler of 30/3/2000 failed the second part of this test
+% (the part with comparison_test1), due to overeager specialization of
+% comparisons involving ENUM_USEREQ types.
+%
+% The Mercury compiler still fails the third part of this test (the part
+% with comparison_test2) with --no-special-preds, because the exception
+% is not propagated across MR_call_engine properly. (It should work fine
+% with the default --special-preds.)
:- module user_defined_equality.
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is det.
+:- pred main(io__state::di, io__state::uo) is cc_multi.
:- implementation.
-:- import_module list, std_util.
+:- import_module list, std_util, exception.
:- type foo ---> bar ; baz
where equality is foo_equal.
@@ -18,7 +29,39 @@
main -->
( { append([bar], [baz], [baz, bar]) } ->
- print("yes"), nl
+ io__write_string("yes\n")
;
- print("no"), nl
+ io__write_string("no\n")
+ ),
+ perform_comparison_test(comparison_test1),
+ perform_comparison_test(comparison_test2).
+
+:- pred perform_comparison_test(pred(T), io__state, io__state).
+:- mode perform_comparison_test(pred(out) is det, di, uo) is cc_multi.
+
+perform_comparison_test(Test) -->
+ { try(Test, TryResult) },
+ (
+ { TryResult = failed },
+ io__write_string("failed\n")
+ ;
+ { TryResult = succeeded(Result) },
+ io__write_string("succeeded: "),
+ io__write(Result),
+ io__write_string("\n")
+ ;
+ { TryResult = exception(Exception) },
+ io__write_string("threw exception: "),
+ io__write(Exception),
+ io__write_string("\n")
).
+
+:- pred comparison_test1(comparison_result::out) is det.
+
+comparison_test1(R) :-
+ compare(R, bar, baz).
+
+:- pred comparison_test2(comparison_result::out) is det.
+
+comparison_test2(R) :-
+ compare(R, [bar], [baz]).
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list