[m-dev.] for review: improvements to type specialization [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Thu Sep 30 16:17:44 AEST 1999
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.9
diff -u -u -r1.9 magic.m
--- magic.m 1999/08/25 06:10:12 1.9
+++ magic.m 1999/09/30 06:03:28
@@ -1140,9 +1140,8 @@
PredInfo0, PredInfo, ProcInfo0, ProcInfo) -->
magic_info_get_module_info(ModuleInfo0),
{ create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0) },
- { ExistQVars = [] },
{ term__context_init(Context) },
- { polymorphism__make_type_info_vars(Types, ExistQVars, Context,
+ { polymorphism__make_type_info_vars(Types, Context,
TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo) },
{ poly_info_extract(PolyInfo, PredInfo0, PredInfo,
ProcInfo0, ProcInfo, ModuleInfo) },
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.306
diff -u -u -r1.306 make_hlds.m
--- make_hlds.m 1999/09/21 07:23:31 1.306
+++ make_hlds.m 1999/09/30 01:04:56
@@ -846,8 +846,9 @@
{ module_info_get_predicate_table(Module0, Preds) },
(
{ MaybePredOrFunc = yes(PredOrFunc) ->
+ adjust_func_arity(PredOrFunc, Arity, PredArity),
predicate_table_search_pf_sym_arity(Preds,
- PredOrFunc, SymName, Arity, PredIds)
+ PredOrFunc, SymName, PredArity, PredIds)
;
predicate_table_search_sym_arity(Preds,
SymName, Arity, PredIds)
@@ -996,47 +997,66 @@
handle_pragma_type_spec_subst(Context, Subst, TVarSet0, PredInfo0,
TVarSet, Types, ExistQVars, ClassContext, SubstOk,
ModuleInfo0, ModuleInfo) -->
- ( { Subst = [] } ->
+ { assoc_list__keys(Subst, VarsToSub) },
+ (
+ { Subst = [] }
+ ->
{ error("handle_pragma_type_spec_subst: empty substitution") }
;
+ { multiple_subst_vars(VarsToSub, MultiSubstVars0) },
+ { MultiSubstVars0 \= [] }
+ ->
+ { list__sort_and_remove_dups(MultiSubstVars0, MultiSubstVars) },
+ report_multiple_subst_vars(PredInfo0, Context,
+ TVarSet0, MultiSubstVars),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ io__set_exit_status(1),
+ { ExistQVars = [] },
+ { Types = [] },
+ { ClassContext = constraints([], []) },
+ { varset__init(TVarSet) },
+ { SubstOk = no }
+ ;
{ pred_info_typevarset(PredInfo0, CalledTVarSet) },
{ varset__create_name_var_map(CalledTVarSet, NameVarIndex0) },
- { assoc_list__keys(Subst, VarsToSub) },
{ list__filter(lambda([Var::in] is semidet, (
varset__lookup_name(TVarSet0, Var, VarName),
\+ map__contains(NameVarIndex0, VarName)
)), VarsToSub, UnknownVarsToSub) },
( { UnknownVarsToSub = [] } ->
- % Check that the substitution makes all types involved
- % ground. This is not strictly necessary, but handling
- % this case with --typeinfo-liveness is tricky (to get the
- % order of any extra typeclass_infos right), and it probably
- % isn't very useful. If this restriction is removed later,
- % remember to report an error for recursive substitutions.
- { map__init(TVarRenaming0) },
- { assoc_list__values(Subst, SubstTypes) },
- { list__filter(lambda([SubstType::in] is semidet, (
- \+ term__is_ground(SubstType)
- )), SubstTypes, NonGroundTypes) },
-
- ( { NonGroundTypes = [] } ->
- { get_new_tvars(VarsToSub, TVarSet0, CalledTVarSet,
- TVarSet, NameVarIndex0, _,
- TVarRenaming0, TVarRenaming) },
+ % Check that the substitution is not recursive.
+ { set__list_to_set(VarsToSub, VarsToSubSet) },
+
+ { assoc_list__values(Subst, SubstTypes0) },
+ { term__vars_list(SubstTypes0, TVarsInSubstTypes0) },
+ { set__list_to_set(TVarsInSubstTypes0, TVarsInSubstTypes) },
+
+ { set__intersect(TVarsInSubstTypes, VarsToSubSet,
+ RecSubstTVars0) },
+ { set__to_sorted_list(RecSubstTVars0, RecSubstTVars) },
+
+ ( { RecSubstTVars = [] } ->
+ { map__init(TVarRenaming0) },
+ { list__append(VarsToSub, TVarsInSubstTypes0,
+ VarsToReplace) },
+
+ { get_new_tvars(VarsToReplace, TVarSet0, CalledTVarSet,
+ TVarSet, NameVarIndex0, _,
+ TVarRenaming0, TVarRenaming) },
% Check that none of the existentially quantified
% variables were substituted.
{ map__apply_to_list(VarsToSub, TVarRenaming,
- RenamedVars) },
+ RenamedVarsToSub) },
{ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars) },
{ list__filter(lambda([RenamedVar::in] is semidet, (
list__member(RenamedVar, ExistQVars)
- )), RenamedVars, SubExistQVars) },
+ )), RenamedVarsToSub, SubExistQVars) },
( { SubExistQVars = [] } ->
{
- map__apply_to_list(VarsToSub, TVarRenaming,
- RenamedVarsToSub),
map__init(TypeSubst0),
+ term__apply_variable_renaming_to_list(SubstTypes0,
+ TVarRenaming, SubstTypes),
assoc_list__from_corresponding_lists(RenamedVarsToSub,
SubstTypes, SubAL),
list__foldl(
@@ -1066,14 +1086,10 @@
{ SubstOk = no }
)
;
- report_non_ground_subst(PredInfo0, Context),
- globals__io_lookup_bool_option(halt_at_warn, Halt),
- ( { Halt = yes } ->
- { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
- io__set_exit_status(1)
- ;
- { ModuleInfo = ModuleInfo0 }
- ),
+ report_recursive_subst(PredInfo0, Context,
+ TVarSet0, RecSubstTVars),
+ io__set_exit_status(1),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
{ ExistQVars = [] },
{ Types = [] },
{ ClassContext = constraints([], []) },
@@ -1093,6 +1109,18 @@
)
).
+:- pred multiple_subst_vars(list(T), list(T)).
+:- mode multiple_subst_vars(in, out) is det.
+
+multiple_subst_vars([], []).
+multiple_subst_vars([H | T], Vars) :-
+ multiple_subst_vars(T, Vars0),
+ ( list__member(H, T) ->
+ Vars = [H | Vars0]
+ ;
+ Vars = Vars0
+ ).
+
:- pred report_subst_existq_tvars(pred_info, prog_context,
list(tvar), io__state, io__state).
:- mode report_subst_existq_tvars(in, in, in, di, uo) is det.
@@ -1100,40 +1128,57 @@
report_subst_existq_tvars(PredInfo0, Context, SubExistQVars) -->
report_pragma_type_spec(PredInfo0, Context),
prog_out__write_context(Context),
- io__write_string(" error: the substitution includes the existentially\n"),
+ io__write_string(
+ " error: the substitution includes the existentially\n"),
prog_out__write_context(Context),
io__write_string(" quantified type "),
{ pred_info_typevarset(PredInfo0, TVarSet) },
report_variables(SubExistQVars, TVarSet),
io__write_string(".\n").
-:- pred report_non_ground_subst(pred_info, prog_context,
- io__state, io__state).
-:- mode report_non_ground_subst(in, in, di, uo) is det.
+:- pred report_recursive_subst(pred_info, prog_context, tvarset,
+ list(tvar), io__state, io__state).
+:- mode report_recursive_subst(in, in, in, in, di, uo) is det.
-report_non_ground_subst(PredInfo0, Context) -->
+report_recursive_subst(PredInfo0, Context, TVarSet, RecursiveVars) -->
report_pragma_type_spec(PredInfo0, Context),
prog_out__write_context(Context),
- io__write_string(
- " warning: the substitution does not make the substituted\n"),
- prog_out__write_context(Context),
- io__write_string(" types ground. The declaration will be ignored.\n"),
+ io__write_string(" error: "),
+ report_variables(RecursiveVars, TVarSet),
+ ( { RecursiveVars = [_] } ->
+ io__write_string(" occurs\n")
+ ;
+ io__write_string(" occur\n")
+ ),
prog_out__write_context(Context),
- io__write_string(
- " This is a limitation of the current implementation\n"),
+ io__write_string(" on both sides of the substitution.\n").
+
+:- pred report_multiple_subst_vars(pred_info, prog_context, tvarset,
+ list(tvar), io__state, io__state).
+:- mode report_multiple_subst_vars(in, in, in, in, di, uo) is det.
+
+report_multiple_subst_vars(PredInfo0, Context, TVarSet, MultiSubstVars) -->
+ report_pragma_type_spec(PredInfo0, Context),
prog_out__write_context(Context),
- io__write_string(" which may be removed in a future release.\n").
+ io__write_string(" error: "),
+ report_variables(MultiSubstVars, TVarSet),
+ ( { MultiSubstVars = [_] } ->
+ io__write_string(" has ")
+ ;
+ io__write_string(" have ")
+ ),
+ io__write_string("multiple replacement types.\n").
:- pred report_unknown_vars_to_subst(pred_info, prog_context, tvarset,
list(tvar), io__state, io__state).
:- mode report_unknown_vars_to_subst(in, in, in, in, di, uo) is det.
-report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, RecursiveVars) -->
+report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, UnknownVars) -->
report_pragma_type_spec(PredInfo0, Context),
prog_out__write_context(Context),
io__write_string(" error: "),
- report_variables(RecursiveVars, TVarSet),
- ( { RecursiveVars = [_] } ->
+ report_variables(UnknownVars, TVarSet),
+ ( { UnknownVars = [_] } ->
io__write_string(" does not ")
;
io__write_string(" do not ")
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.171
diff -u -u -r1.171 polymorphism.m
--- polymorphism.m 1999/09/21 07:09:58 1.171
+++ polymorphism.m 1999/09/29 00:43:15
@@ -330,9 +330,9 @@
% variables to the appropriate type_info structures for the types.
% Update the varset and vartypes accordingly.
-:- pred polymorphism__make_type_info_vars(list(type), existq_tvars,
+:- pred polymorphism__make_type_info_vars(list(type),
term__context, list(prog_var), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_type_info_vars(in, in, in, out, out, in, out) is det.
+:- mode polymorphism__make_type_info_vars(in, in, out, out, in, out) is det.
% polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
% ModuleInfo, Goals, TypeInfoVar, ...):
@@ -349,10 +349,9 @@
%
:- pred polymorphism__gen_extract_type_info(tvar, prog_var, int, module_info,
list(hlds_goal), prog_var, prog_varset, map(prog_var, type),
- map(tvar, type_info_locn), prog_varset, map(prog_var, type),
- map(tvar, type_info_locn)).
+ prog_varset, map(prog_var, type)).
:- mode polymorphism__gen_extract_type_info(in, in, in, in, out, out,
- in, in, in, out, out, out) is det.
+ in, in, out, out) is det.
:- type poly_info.
@@ -396,6 +395,10 @@
:- pred polymorphism__type_info_type((type), (type)).
:- mode polymorphism__type_info_type(in, out) is semidet.
+ % Construct the type of the type_info for the given type.
+:- pred polymorphism__build_type_info_type((type), (type)).
+:- mode polymorphism__build_type_info_type(in, out) is det.
+
% Succeed if the predicate is one of the predicates defined in
% library/private_builtin.m to extract type_infos or typeclass_infos
% from typeclass_infos.
@@ -723,26 +726,26 @@
clauses_info_headvars(ClausesInfo, HeadVars),
clauses_info_typeclass_info_varmap(ClausesInfo,
TypeClassInfoVarMap),
- clauses_info_type_info_varmap(ClausesInfo,
- TypeInfoVarMap),
- clauses_info_varset(ClausesInfo,
- VarSet),
+ clauses_info_type_info_varmap(ClausesInfo, TypeInfoVarMap),
+ clauses_info_varset(ClausesInfo, VarSet),
+ clauses_info_vartypes(ClausesInfo, VarTypes),
proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
proc_info_set_typeclass_info_varmap(ProcInfo1,
TypeClassInfoVarMap, ProcInfo2),
proc_info_set_typeinfo_varmap(ProcInfo2,
TypeInfoVarMap, ProcInfo3),
- proc_info_set_varset(ProcInfo3, VarSet, ProcInfo4)
+ proc_info_set_varset(ProcInfo3, VarSet, ProcInfo4),
+ proc_info_set_vartypes(ProcInfo4, VarTypes, ProcInfo5)
;
- copy_clauses_to_proc(ProcId, ClausesInfo, ProcInfo0, ProcInfo4)
+ copy_clauses_to_proc(ProcId, ClausesInfo, ProcInfo0, ProcInfo5)
),
%
% add the ExtraArgModes to the proc_info argmodes
%
- proc_info_argmodes(ProcInfo4, ArgModes1),
+ proc_info_argmodes(ProcInfo5, ArgModes1),
list__append(ExtraArgModes, ArgModes1, ArgModes),
- proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo).
+ proc_info_set_argmodes(ProcInfo5, ArgModes, ProcInfo).
% XXX the following code ought to be rewritten to handle
% existential/universal type_infos and type_class_infos
@@ -880,7 +883,7 @@
UnconstrainedTVars, TypeInfoHeadVars,
ExistTypeClassInfoHeadVars, Goal0, Goal, Info0, Info) :-
poly_info_get_var_types(Info0, VarTypes0),
- pred_info_arg_types(PredInfo, _ArgTypeVarSet, ExistQVars, ArgTypes),
+ pred_info_arg_types(PredInfo, ArgTypes),
pred_info_get_class_context(PredInfo, ClassContext),
%
@@ -925,9 +928,9 @@
%
% figure out the list of universally quantified type variables
%
- term__vars_list(ArgTypes, HeadTypeVars0),
- list__remove_dups(HeadTypeVars0, HeadTypeVars),
- list__delete_elems(HeadTypeVars, ExistQVars, UnivQTVars),
+ %term__vars_list(ArgTypes, HeadTypeVars0),
+ %list__remove_dups(HeadTypeVars0, HeadTypeVars),
+ %list__delete_elems(HeadTypeVars, ExistQVars, UnivQTVars),
%
% apply the type bindings to the unconstrained type variables
@@ -938,7 +941,7 @@
UnconstrainedTVarTerms),
term__apply_substitution_to_list(UnconstrainedTVarTerms,
TypeSubst, ActualTypes),
- polymorphism__make_type_info_vars(ActualTypes, UnivQTVars, Context,
+ polymorphism__make_type_info_vars(ActualTypes, Context,
TypeInfoVars, ExtraTypeInfoGoals, Info2, Info),
polymorphism__assign_var_list(TypeInfoHeadVars, TypeInfoVars,
ExtraTypeInfoUnifyGoals),
@@ -1004,7 +1007,6 @@
%
( { GenericCall = aditi_builtin(aditi_insert(_), _) } ->
% Aditi base relations must be monomorphic.
- { ExistQVars = [] },
{ term__context_init(Context) },
=(PolyInfo),
@@ -1013,7 +1015,7 @@
{ get_state_args_det(Args0, TupleArgs, _, _) },
{ map__apply_to_list(TupleArgs, VarTypes, TupleTypes) },
- polymorphism__make_type_info_vars(TupleTypes, ExistQVars,
+ polymorphism__make_type_info_vars(TupleTypes,
Context, TypeInfoVars, TypeInfoGoals),
{ list__append(TypeInfoVars, Args0, Args) },
@@ -1520,7 +1522,7 @@
% create type_info variables for the _unconstrained_
% existentially quantified type variables
%
- polymorphism__make_type_info_vars(ExistentialTypes, [],
+ polymorphism__make_type_info_vars(ExistentialTypes,
Context, ExtraTypeInfoVars, ExtraTypeInfoGoals,
PolyInfo3, PolyInfo),
@@ -1824,7 +1826,7 @@
term__apply_rec_substitution_to_list(PredTypes0, TypeSubst,
PredTypes),
- polymorphism__make_type_info_vars(PredTypes, PredExistQVars,
+ polymorphism__make_type_info_vars(PredTypes,
Context, ExtraTypeInfoVars, ExtraTypeInfoGoals,
Info4, Info),
list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
@@ -2102,7 +2104,7 @@
% that are constrained by this. These
% are packaged in the typeclass_info
polymorphism__make_type_info_vars(
- ConstrainedTypes, ExistQVars, Context,
+ ConstrainedTypes, Context,
InstanceExtraTypeInfoVars, TypeInfoGoals,
Info0, Info1),
@@ -2430,21 +2432,21 @@
% variables to the appropriate type_info structures for the types.
% Update the varset and vartypes accordingly.
-polymorphism__make_type_info_vars([], _, _, [], [], Info, Info).
-polymorphism__make_type_info_vars([Type | Types], ExistQVars, Context,
+polymorphism__make_type_info_vars([], _, [], [], Info, Info).
+polymorphism__make_type_info_vars([Type | Types], Context,
ExtraVars, ExtraGoals, Info0, Info) :-
- polymorphism__make_type_info_var(Type, ExistQVars, Context,
+ polymorphism__make_type_info_var(Type, Context,
Var, ExtraGoals1, Info0, Info1),
- polymorphism__make_type_info_vars(Types, ExistQVars, Context,
+ polymorphism__make_type_info_vars(Types, Context,
ExtraVars2, ExtraGoals2, Info1, Info),
ExtraVars = [Var | ExtraVars2],
list__append(ExtraGoals1, ExtraGoals2, ExtraGoals).
-:- pred polymorphism__make_type_info_var(type, existq_tvars, prog_context,
+:- pred polymorphism__make_type_info_var(type, prog_context,
prog_var, list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_type_info_var(in, in, in, out, out, in, out) is det.
+:- mode polymorphism__make_type_info_var(in, in, out, out, in, out) is det.
-polymorphism__make_type_info_var(Type, ExistQVars, Context, Var, ExtraGoals,
+polymorphism__make_type_info_var(Type, Context, Var, ExtraGoals,
Info0, Info) :-
%
% First handle statically known types
@@ -2466,8 +2468,7 @@
hlds_out__pred_or_func_to_str(PredOrFunc, PredOrFuncStr),
TypeId = unqualified(PredOrFuncStr) - 0,
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
- yes, ExistQVars, Context,
- Var, ExtraGoals, Info0, Info)
+ yes, Context, Var, ExtraGoals, Info0, Info)
;
type_to_type_id(Type, TypeId, TypeArgs)
->
@@ -2477,7 +2478,7 @@
% at the top of the module.
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
- no, ExistQVars, Context, Var, ExtraGoals, Info0, Info)
+ no, Context, Var, ExtraGoals, Info0, Info)
;
%
% Now handle the cases of types which are not known statically
@@ -2512,16 +2513,16 @@
).
:- pred polymorphism__construct_type_info(type, type_id, list(type),
- bool, existq_tvars, prog_context, prog_var, list(hlds_goal),
+ bool, prog_context, prog_var, list(hlds_goal),
poly_info, poly_info).
-:- mode polymorphism__construct_type_info(in, in, in, in, in, in, out, out,
+:- mode polymorphism__construct_type_info(in, in, in, in, in, out, out,
in, out) is det.
polymorphism__construct_type_info(Type, TypeId, TypeArgs, IsHigherOrder,
- ExistQVars, Context, Var, ExtraGoals, Info0, Info) :-
+ Context, Var, ExtraGoals, Info0, Info) :-
% Create the typeinfo vars for the arguments
- polymorphism__make_type_info_vars(TypeArgs, ExistQVars, Context,
+ polymorphism__make_type_info_vars(TypeArgs, Context,
ArgTypeInfoVars, ArgTypeInfoGoals, Info0, Info1),
poly_info_get_varset(Info1, VarSet1),
@@ -2864,10 +2865,8 @@
string__int_to_string(VarNum, VarNumStr),
string__append("TypeInfo_", VarNumStr, Name),
varset__name_var(VarSet1, Var, Name, VarSet),
- mercury_private_builtin_module(PrivateBuiltin),
- construct_type(qualified(PrivateBuiltin, Symbol) - 1, [Type],
- UnifyPredType),
- map__set(VarTypes0, Var, UnifyPredType, VarTypes).
+ polymorphism__build_type_info_type(Symbol, Type, TypeInfoType),
+ map__set(VarTypes0, Var, TypeInfoType, VarTypes).
%---------------------------------------------------------------------------%
@@ -2901,19 +2900,15 @@
TypeInfoVar, PolyInfo0, PolyInfo) :-
poly_info_get_varset(PolyInfo0, VarSet0),
poly_info_get_var_types(PolyInfo0, VarTypes0),
- poly_info_get_type_info_map(PolyInfo0, TypeInfoLocns0),
poly_info_get_module_info(PolyInfo0, ModuleInfo),
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, TypeInfoLocns0,
- VarSet, VarTypes, TypeInfoLocns),
- poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo1),
- poly_info_set_type_info_map(TypeInfoLocns, PolyInfo1, PolyInfo).
+ VarSet0, VarTypes0, VarSet, VarTypes),
+ poly_info_set_varset_and_types(VarSet, VarTypes, PolyInfo0, PolyInfo).
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, TypeInfoLocns0,
- VarSet, VarTypes, TypeInfoLocns0) :-
+ VarSet0, VarTypes0, VarSet, VarTypes) :-
% We need a tvarset to pass to get_pred_id_and_proc_id
varset__init(DummyTVarSet0),
@@ -3109,6 +3104,17 @@
type_to_type_id(TypeInfoType,
qualified(PrivateBuiltin, "type_info") - 1,
[Type]).
+
+polymorphism__build_type_info_type(Type, TypeInfoType) :-
+ polymorphism__build_type_info_type("type_info", Type, TypeInfoType).
+
+:- pred polymorphism__build_type_info_type(string, (type), (type)).
+:- mode polymorphism__build_type_info_type(in, in, out) is det.
+
+polymorphism__build_type_info_type(Symbol, Type, TypeInfoType) :-
+ mercury_private_builtin_module(PrivateBuiltin),
+ construct_type(qualified(PrivateBuiltin, Symbol) - 1,
+ [Type], TypeInfoType).
%---------------------------------------------------------------------------%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.14
diff -u -u -r1.14 post_typecheck.m
--- post_typecheck.m 1999/09/12 04:26:49 1.14
+++ post_typecheck.m 1999/09/29 00:43:16
@@ -589,8 +589,22 @@
%
post_typecheck__finish_imported_pred(ModuleInfo, PredId,
PredInfo0, PredInfo) -->
+ % Make sure the var-types field in the clauses_info is
+ % valid for imported predicates.
+ % Unification procedures have clauses generated, so
+ % they already have valid var-types.
+ { pred_info_is_pseudo_imported(PredInfo0) ->
+ PredInfo1 = PredInfo0
+ ;
+ pred_info_clauses_info(PredInfo0, ClausesInfo0),
+ clauses_info_headvars(ClausesInfo0, HeadVars),
+ pred_info_arg_types(PredInfo0, ArgTypes),
+ map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
+ clauses_info_set_vartypes(ClausesInfo0, VarTypes, ClausesInfo),
+ pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo1)
+ },
post_typecheck__propagate_types_into_modes(ModuleInfo, PredId,
- PredInfo0, PredInfo).
+ PredInfo1, PredInfo).
%
% Now that the assertion has finished being typechecked,
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.69
diff -u -u -r1.69 simplify.m
--- simplify.m 1999/09/20 13:44:14 1.69
+++ simplify.m 1999/09/29 00:43:39
@@ -1202,9 +1202,8 @@
% Call polymorphism.m to create the type_infos
%
create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2, PolyInfo0),
- ExistQVars = [],
term__context_init(Context),
- polymorphism__make_type_info_vars(Types, ExistQVars, Context,
+ polymorphism__make_type_info_vars(Types, Context,
TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo),
poly_info_extract(PolyInfo, PredInfo0, PredInfo,
ProcInfo0, ProcInfo, ModuleInfo1),
@@ -1258,12 +1257,10 @@
simplify_info_get_module_info(Info0, ModuleInfo),
simplify_info_get_varset(Info0, VarSet0),
simplify_info_get_var_types(Info0, VarTypes0),
- simplify_info_get_typeinfo_map(Info0, TypeInfoLocns0),
polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar,
- VarSet0, VarTypes0, TypeInfoLocns0,
- VarSet, VarTypes, _TypeInfoLocns),
+ VarSet0, VarTypes0, VarSet, VarTypes),
simplify_info_set_var_types(Info0, VarTypes, Info1),
simplify_info_set_varset(Info1, VarSet, Info).
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.11
diff -u -u -r1.11 table_gen.m
--- table_gen.m 1999/07/29 07:36:56 1.11
+++ table_gen.m 1999/09/29 00:43:43
@@ -1345,9 +1345,8 @@
% Call polymorphism.m to create the type_infos
%
create_poly_info(ModuleInfo0, PredInfo0, ProcInfo2, PolyInfo0),
- ExistQVars = [],
term__context_init(Context),
- polymorphism__make_type_info_vars(Types, ExistQVars, Context,
+ polymorphism__make_type_info_vars(Types, Context,
TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo),
poly_info_extract(PolyInfo, PredInfo0, PredInfo,
ProcInfo0, ProcInfo, ModuleInfo),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.72
diff -u -u -r1.72 type_util.m
--- type_util.m 1999/09/17 17:19:13 1.72
+++ type_util.m 1999/09/29 00:43:48
@@ -45,6 +45,12 @@
:- pred type_id_is_higher_order(type_id, pred_or_func, lambda_eval_method).
:- mode type_id_is_higher_order(in, out, out) is semidet.
+ % return true iff there was a `where equality is <predname>'
+ % declaration for the specified type, and return the name of
+ % the equality predicate and the context of the type declaration.
+:- pred type_has_user_defined_equality_pred(module_info, (type), sym_name).
+:- mode type_has_user_defined_equality_pred(in, in, out) 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
@@ -445,6 +451,13 @@
PorFStr = "func",
PredOrFunc = function
).
+
+type_has_user_defined_equality_pred(ModuleInfo, Type, SymName) :-
+ module_info_types(ModuleInfo, TypeTable),
+ type_to_type_id(Type, TypeId, _TypeArgs),
+ map__search(TypeTable, TypeId, TypeDefn),
+ hlds_data__get_type_defn_body(TypeDefn, TypeBody),
+ TypeBody = du_type(_, _, _, yes(SymName)).
% Certain types, e.g. io__state and store__store(S),
% are just dummy types used to ensure logical semantics;
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.152
diff -u -u -r1.152 reference_manual.texi
--- reference_manual.texi 1999/09/12 04:27:25 1.152
+++ reference_manual.texi 1999/09/30 00:13:46
@@ -5207,15 +5207,6 @@
specializations when invoked with @samp{--user-guided-type-specialization},
which is enabled at optimization level @samp{-O2} or higher.
-In the current implementation, the replacement types must be ground.
-Substitutions such as @w{@samp{T = list(U)}} are not supported.
-The compiler will warn about such substitutions, and will ignore
-the request for specialization. This restriction may be lifted in the future.
- at c The main reason for this restriction is that it is tricky to ensure that
- at c any extra typeclass_infos that may be needed are ordered the same way in
- at c different modules. The efficiency gain from replacing a type variable with
- at c a non-ground type will usually be pretty small anyway.
-
@node Obsolescence
@section Obsolescence
Index: library/varset.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/varset.m,v
retrieving revision 1.60
diff -u -u -r1.60 varset.m
--- varset.m 1998/11/20 04:10:36 1.60
+++ varset.m 1999/09/29 04:03:21
@@ -119,6 +119,22 @@
:- pred varset__merge_subst(varset(T), varset(T), varset(T), substitution(T)).
:- mode varset__merge_subst(in, in, out, out) is det.
+ % Same as varset__merge, except that the names of variables
+ % in NewVarSet are not included in the final varset.
+ % This is useful if varset__create_name_var_map needs
+ % to be used on the resulting varset.
+
+:- pred varset__merge_without_names(varset(T), varset(T), list(term(T)),
+ varset(T), list(term(T))).
+:- mode varset__merge_without_names(in, in, in, out, out) is det.
+
+ % As above, except return the substitution directly
+ % rather than applying it to a list of terms.
+
+:- pred varset__merge_subst_without_names(varset(T),
+ varset(T), varset(T), substitution(T)).
+:- mode varset__merge_subst_without_names(in, in, out, out) is det.
+
% get the bindings for all the bound variables.
:- pred varset__get_bindings(varset(T), substitution(T)).
:- mode varset__get_bindings(in, out) is det.
@@ -170,7 +186,8 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module int, list, map, std_util, assoc_list, set, require, string.
+:- import_module bool, int, list, map, std_util, assoc_list.
+:- import_module set, require, string.
:- type varset(T) ---> varset(
var_supply(T),
@@ -346,22 +363,47 @@
% this substition to the list of terms.
varset__merge(VarSet0, VarSet1, TermList0, VarSet, TermList) :-
- varset__merge_subst(VarSet0, VarSet1, VarSet, Subst),
+ IncludeNames = yes,
+ varset__merge_subst(IncludeNames, VarSet0, VarSet1, VarSet, Subst),
+ term__apply_substitution_to_list(TermList0, Subst, TermList).
+
+varset__merge_without_names(VarSet0, VarSet1, TermList0, VarSet, TermList) :-
+ IncludeNames = no,
+ varset__merge_subst(IncludeNames,
+ VarSet0, VarSet1, VarSet, Subst),
term__apply_substitution_to_list(TermList0, Subst, TermList).
varset__merge_subst(VarSet0, varset(MaxId, Names, Vals),
VarSet, Subst) :-
+ IncludeNames = yes,
+ varset__merge_subst(IncludeNames, VarSet0, varset(MaxId, Names, Vals),
+ VarSet, Subst).
+
+varset__merge_subst_without_names(VarSet0, varset(MaxId, Names, Vals),
+ VarSet, Subst) :-
+ IncludeNames = no,
+ varset__merge_subst(IncludeNames, VarSet0, varset(MaxId, Names, Vals),
+ VarSet, Subst).
+
+:- pred varset__merge_subst(bool, varset(T), varset(T), varset(T),
+ substitution(T)).
+:- mode varset__merge_subst(in, in, in, out, out) is det.
+
+varset__merge_subst(IncludeNames, VarSet0, varset(MaxId, Names, Vals),
+ VarSet, Subst) :-
term__init_var_supply(N),
map__init(Subst0),
- varset__merge_subst_2(N, MaxId, Names, Vals, VarSet0, Subst0,
- VarSet, Subst).
+ varset__merge_subst_2(IncludeNames, N, MaxId, Names, Vals,
+ VarSet0, Subst0, VarSet, Subst).
-:- pred varset__merge_subst_2(var_supply(T), var_supply(T), map(var(T), string),
+:- pred varset__merge_subst_2(bool, var_supply(T),
+ var_supply(T), map(var(T), string),
map(var(T), term(T)), varset(T), substitution(T),
varset(T), substitution(T)).
-:- mode varset__merge_subst_2(in, in, in, in, in, in, out, out) is det.
+:- mode varset__merge_subst_2(in, in, in, in, in, in, in, out, out) is det.
-varset__merge_subst_2(N, Max, Names, Vals, VarSet0, Subst0, VarSet, Subst) :-
+varset__merge_subst_2(IncludeNames, N, Max, Names, Vals,
+ VarSet0, Subst0, VarSet, Subst) :-
( N = Max ->
VarSet = VarSet0,
Subst0 = Subst
@@ -369,6 +411,7 @@
varset__new_var(VarSet0, VarId, VarSet1),
term__create_var(N, VarN, N1),
(
+ IncludeNames = yes,
map__search(Names, VarN, Name)
->
varset__name_var(VarSet1, VarId, Name, VarSet2)
@@ -376,8 +419,8 @@
VarSet2 = VarSet1
),
map__set(Subst0, VarN, term__variable(VarId), Subst1),
- varset__merge_subst_2(N1, Max, Names, Vals, VarSet2, Subst1,
- VarSet, Subst)
+ varset__merge_subst_2(IncludeNames, N1, Max, Names,
+ Vals, VarSet2, Subst1, VarSet, Subst)
).
%-----------------------------------------------------------------------------%
Index: tests/hard_coded/type_spec.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/type_spec.exp,v
retrieving revision 1.1
diff -u -u -r1.1 type_spec.exp
--- type_spec.exp 1999/04/23 01:03:41 1.1
+++ type_spec.exp 1999/09/30 00:54:40
@@ -2,3 +2,7 @@
[3]
Succeeded
Succeeded
+Succeeded
+Failed
+Succeeded
+Failed
Index: tests/hard_coded/type_spec.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/type_spec.m,v
retrieving revision 1.1
diff -u -u -r1.1 type_spec.m
--- type_spec.m 1999/04/23 01:03:42 1.1
+++ type_spec.m 1999/09/30 00:50:33
@@ -43,6 +43,17 @@
:- pred list_all_zero(list(T)::in) is semidet <= all_zero(T).
:- pragma type_spec(list_all_zero/1, T = int).
+ % Test specialization where the substituted types are non-ground.
+:- pred my_unify(T::in, T::in) is semidet.
+:- pragma type_spec(my_unify/2, T = list(U)).
+
+:- type no_tag
+ ---> no_tag(int).
+
+ % Test specialization of unifications involving no tag types.
+:- pred unify_no_tag(no_tag::in, no_tag::in) is semidet.
+:- pragma no_inline(unify_no_tag/2).
+
:- implementation.
main -->
@@ -61,6 +72,26 @@
io__write_string("Succeeded\n")
;
io__write_string("Failed\n")
+ ),
+ ( { my_unify([1,2,3], [1,2,3]) } ->
+ io__write_string("Succeeded\n")
+ ;
+ io__write_string("Failed\n")
+ ),
+ ( { my_unify([1,2,3], [1]) } ->
+ io__write_string("Succeeded\n")
+ ;
+ io__write_string("Failed\n")
+ ),
+ ( { unify_no_tag(no_tag(1), no_tag(1)) } ->
+ io__write_string("Succeeded\n")
+ ;
+ io__write_string("Failed\n")
+ ),
+ ( { unify_no_tag(no_tag(1), no_tag(2)) } ->
+ io__write_string("Succeeded\n")
+ ;
+ io__write_string("Failed\n")
).
type_spec([], [], []).
@@ -106,3 +137,7 @@
list_all_zero(T).
is_zero(0).
+
+my_unify(X, X).
+
+unify_no_tag(X, X).
Index: tests/invalid/type_spec.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/type_spec.err_exp,v
retrieving revision 1.1
diff -u -u -r1.1 type_spec.err_exp
--- type_spec.err_exp 1999/04/23 01:03:50 1.1
+++ type_spec.err_exp 1999/09/30 01:21:40
@@ -2,14 +2,14 @@
type_spec.m:010: error: variable `U' does not occur in the `:- pred' declaration.
type_spec.m:011: Error: `:- pragma type_spec' declaration for
type_spec.m:011: `type_spec:type_spec1/1' specifies non-existent mode.
-type_spec.m:012: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec1/1':
-type_spec.m:012: warning: the substitution does not make the substituted
-type_spec.m:012: types ground. The declaration will be ignored.
-type_spec.m:012: This is a limitation of the current implementation
-type_spec.m:012: which may be removed in a future release.
type_spec.m:013: Error: `:- pragma type_spec' declaration for type_spec:type_spec1/2
type_spec.m:013: without corresponding `pred' or `func' declaration.
type_spec.m:024: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec2/1':
type_spec.m:024: error: the substitution includes the existentially
type_spec.m:024: quantified type variable `U'.
+type_spec.m:026: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec2/1':
+type_spec.m:026: error: variable `U' occurs
+type_spec.m:026: on both sides of the substitution.
+type_spec.m:028: In `:- pragma type_spec' declaration for predicate `type_spec:type_spec2/1':
+type_spec.m:028: error: variable `U' has multiple replacement types.
For more information, try recompiling with `-E'.
Index: tests/invalid/type_spec.m
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/type_spec.m,v
retrieving revision 1.1
diff -u -u -r1.1 type_spec.m
--- type_spec.m 1999/04/23 01:03:51 1.1
+++ type_spec.m 1999/09/30 01:20:46
@@ -23,3 +23,6 @@
:- pragma type_spec(type_spec2/1, U = int).
+:- pragma type_spec(type_spec2/1, U = list(U)).
+
+:- pragma type_spec(type_spec2/1, (U = int, U = list(int))).
--------------------------------------------------------------------------
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