for review: type specialisation [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Sun Aug 30 15:46:08 AEST 1998
Index: NEWS
===================================================================
RCS file: /home/staff/zs/imp/mercury/NEWS,v
retrieving revision 1.114
diff -u -t -u -r1.114 NEWS
--- NEWS 1998/08/10 07:16:44 1.114
+++ NEWS 1998/08/26 06:17:54
@@ -356,6 +356,13 @@
over data structures. Deforestation is enabled at optimization level
`-O3' or higher, or by using the `--deforestation' option.
+* The compiler can now perform type specialization.
+
+ Type specialization removes the overhead of polymorphic code, including
+ code which uses typeclasses. The disadvantage is increased code size.
+ Currently we do not perform inter-module type specialization.
+ Type specialization is enabled by using the `--type-specialization' option.
+
* We've added support for "transitive" inter-module analysis.
With the previous support for inter-module optimization, when
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.37
diff -u -t -u -r1.37 bytecode_gen.m
--- bytecode_gen.m 1998/06/09 02:12:02 1.37
+++ bytecode_gen.m 1998/08/12 04:16:54
@@ -628,7 +628,7 @@
TypeArity)
;
ConsId = base_typeclass_info_const(ModuleName, ClassId,
- Instance),
+ _, Instance),
ByteConsId = base_typeclass_info_const(ModuleName, ClassId,
Instance)
).
Index: compiler/code_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/code_util.m,v
retrieving revision 1.100
diff -u -t -u -r1.100 code_util.m
--- code_util.m 1998/07/20 10:00:31 1.100
+++ code_util.m 1998/08/12 04:15:24
@@ -673,7 +673,7 @@
code_util__cons_id_to_tag(pred_const(P,M), _, _, pred_closure_tag(P,M)).
code_util__cons_id_to_tag(base_type_info_const(M,T,A), _, _,
base_type_info_constant(M,T,A)).
-code_util__cons_id_to_tag(base_typeclass_info_const(M,C,N), _, _,
+code_util__cons_id_to_tag(base_typeclass_info_const(M,C,_,N), _, _,
base_typeclass_info_constant(M,C,N)).
code_util__cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo, Tag) :-
(
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dependency_graph.m,v
retrieving revision 1.35
diff -u -t -u -r1.35 dependency_graph.m
--- dependency_graph.m 1998/06/09 02:12:22 1.35
+++ dependency_graph.m 1998/08/12 04:17:16
@@ -323,8 +323,8 @@
).
dependency_graph__add_arcs_in_cons(base_type_info_const(_, _, _), _Caller,
DepGraph, DepGraph).
-dependency_graph__add_arcs_in_cons(base_typeclass_info_const(_, _, _), _Caller,
- DepGraph, DepGraph).
+dependency_graph__add_arcs_in_cons(base_typeclass_info_const(_, _, _, _),
+ _Caller, DepGraph, DepGraph).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/dnf.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dnf.m,v
retrieving revision 1.32
diff -u -t -u -r1.32 dnf.m
--- dnf.m 1998/07/08 20:55:55 1.32
+++ dnf.m 1998/07/27 03:17:46
@@ -384,7 +384,7 @@
% This ClassContext is a conservative approximation.
% We could get rid of some constraints on variables
% that are not part of the goal.
- hlds_pred__define_new_pred(Goal0, Goal, ArgVars, InstMap0, PredName,
+ hlds_pred__define_new_pred(Goal0, Goal, ArgVars, _, InstMap0, PredName,
TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId),
PredProcId = proc(PredId, _).
Index: compiler/goal_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/goal_util.m,v
retrieving revision 1.47
diff -u -t -u -r1.47 goal_util.m
--- goal_util.m 1998/07/08 20:56:04 1.47
+++ goal_util.m 1998/07/27 00:47:54
@@ -69,7 +69,7 @@
%
% goal_util__extra_nonlocal_typeinfos(TypeInfoMap, TypeClassInfoMap,
- % VarTypes, ExistQVars, Goal, NonLocalTypeInfos):
+ % VarTypes, ExistQVars, NonLocals, NonLocalTypeInfos):
% compute which type-info and type-class-info variables
% may need to be non-local to a goal.
%
@@ -89,7 +89,7 @@
%
:- pred goal_util__extra_nonlocal_typeinfos(map(tvar, type_info_locn),
map(class_constraint, var), map(var, type), existq_tvars,
- hlds_goal, set(var)).
+ set(var), set(var)).
:- mode goal_util__extra_nonlocal_typeinfos(in, in, in, in, in, out) is det.
% See whether the goal is a branched structure.
@@ -539,9 +539,7 @@
%-----------------------------------------------------------------------------%
goal_util__extra_nonlocal_typeinfos(TypeVarMap, TypeClassVarMap, VarTypes,
- ExistQVars, Goal0, NonLocalTypeInfos) :-
- Goal0 = _ - GoalInfo0,
- goal_info_get_nonlocals(GoalInfo0, NonLocals),
+ ExistQVars, NonLocals, NonLocalTypeInfos) :-
set__to_sorted_list(NonLocals, NonLocalsList),
map__apply_to_list(NonLocalsList, VarTypes, NonLocalsTypes),
term__vars_list(NonLocalsTypes, NonLocalTypeVars),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.60
diff -u -t -u -r1.60 handle_options.m
--- handle_options.m 1998/07/27 01:04:38 1.60
+++ handle_options.m 1998/08/26 07:13:45
@@ -364,12 +364,6 @@
option_implies(procid_stack_layout, basic_stack_layout, bool(yes)),
option_implies(agc_stack_layout, basic_stack_layout, bool(yes)),
- % XXX higher_order.m does not update the typeinfo_varmap
- % for specialised versions.
- % This causes the compiler to abort in unused_args.m when compiling
- % tests/valid/agc_ho_pred.m with `-O3 --intermodule-optimization'.
- option_implies(typeinfo_liveness, optimize_higher_order, bool(no)),
-
% XXX deforestation does not perform folding on polymorphic
% predicates correctly with --typeinfo-liveness.
option_implies(typeinfo_liveness, deforestation, bool(no)),
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.25
diff -u -t -u -r1.25 hlds_data.m
--- hlds_data.m 1998/07/08 20:56:10 1.25
+++ hlds_data.m 1998/08/12 04:19:21
@@ -36,12 +36,14 @@
% whereas a code_addr_const is just an address.
; base_type_info_const(module_name, string, int)
% module name, type name, type arity
- ; base_typeclass_info_const(module_name, class_id,
- string)
+ ; base_typeclass_info_const(module_name,
+ class_id, int, string)
% name of module containing instance
- % declaration, class name and arity, a string
- % encoding the type names and arities of
- % arguments to the instance declaration
+ % declaration (not filled in by
+ % polymorphism.m - why?), class name and arity,
+ % class instance, a string encoding the type
+ % names and arities of the arguments to the
+ % instance declaration
.
% A cons_defn is the definition of a constructor (i.e. a constant
@@ -122,7 +124,7 @@
error("cons_id_arity: can't get arity of code_addr_const").
cons_id_arity(base_type_info_const(_, _, _), _) :-
error("cons_id_arity: can't get arity of base_type_info_const").
-cons_id_arity(base_typeclass_info_const(_, _, _), _) :-
+cons_id_arity(base_typeclass_info_const(_, _, _, _), _) :-
error("cons_id_arity: can't get arity of base_typeclass_info_const").
make_functor_cons_id(term__atom(Name), Arity, cons(unqualified(Name), Arity)).
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.199
diff -u -t -u -r1.199 hlds_out.m
--- hlds_out.m 1998/08/05 08:45:54 1.199
+++ hlds_out.m 1998/08/25 01:14:57
@@ -217,7 +217,7 @@
hlds_out__cons_id_to_string(pred_const(_, _), "<pred>").
hlds_out__cons_id_to_string(code_addr_const(_, _), "<code_addr>").
hlds_out__cons_id_to_string(base_type_info_const(_, _, _), "<base_type_info>").
-hlds_out__cons_id_to_string(base_typeclass_info_const(_, _, _),
+hlds_out__cons_id_to_string(base_typeclass_info_const(_, _, _, _),
"<base_typeclass_info>").
hlds_out__write_cons_id(cons(SymName, Arity)) -->
@@ -238,7 +238,7 @@
io__write_string("<code_addr>").
hlds_out__write_cons_id(base_type_info_const(_, _, _)) -->
io__write_string("<base_type_info>").
-hlds_out__write_cons_id(base_typeclass_info_const(_, _, _)) -->
+hlds_out__write_cons_id(base_typeclass_info_const(_, _, _, _)) -->
io__write_string("<base_typeclass_info>").
% The code of this predicate duplicates the functionality of
@@ -530,7 +530,7 @@
( { map__is_empty(Proofs) } ->
[]
;
- hlds_out__write_constraint_proofs(Indent, VarSet,
+ hlds_out__write_constraint_proofs(Indent, TVarSet,
Proofs),
io__write_string("\n")
)
@@ -1532,7 +1532,7 @@
io__write_string(")")
;
{ ConsId = base_typeclass_info_const(Module,
- class_id(Name, Arity), Instance) },
+ class_id(Name, Arity), _, Instance) },
io__write_string("base_typeclass_info("""),
prog_out__write_sym_name(Module),
io__write_string(""", """),
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.51
diff -u -t -u -r1.51 hlds_pred.m
--- hlds_pred.m 1998/08/13 02:20:07 1.51
+++ hlds_pred.m 1998/08/25 04:29:23
@@ -15,8 +15,8 @@
:- import_module hlds_data, hlds_goal, hlds_module, llds, prog_data, instmap.
:- import_module purity, globals.
-:- import_module bool, list, set, map, std_util, term, varset.
:- import_module term_util.
+:- import_module bool, list, set, map, std_util, term, varset.
:- implementation.
@@ -265,18 +265,20 @@
:- pred type_info_locn_set_var(type_info_locn::in, var::in,
type_info_locn::out) is det.
- % hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, PredName,
- % TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
+ % hlds_pred__define_new_pred(Goal, CallGoal, Args, ExtraArgs, InstMap,
+ % PredName, TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
% VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId)
%
% Create a new predicate for the given goal, returning a goal to
- % call the created predicate.
-:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var),
+ % call the created predicate. ExtraArgs is the list of extra
+ % type_infos and typeclass_infos required by --typeinfo-liveness
+ % which were added to the front of the argument list.
+:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var), list(var),
instmap, string, tvarset, map(var, type),
class_constraints, map(tvar, type_info_locn),
map(class_constraint, var), varset, pred_markers,
module_info, module_info, pred_proc_id).
-:- mode hlds_pred__define_new_pred(in, out, in, in, in, in, in,
+:- mode hlds_pred__define_new_pred(in, out, in, out, in, in, in, in,
in, in, in, in, in, in, out, out) is det.
% Various predicates for accessing the information stored in the
@@ -839,9 +841,9 @@
%-----------------------------------------------------------------------------%
-hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, InstMap0, PredName, TVarSet,
- VarTypes0, ClassContext, TVarMap, TCVarMap, VarSet0,
- Markers, ModuleInfo0, ModuleInfo, PredProcId) :-
+hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, ExtraTypeInfos, InstMap0,
+ PredName, TVarSet, VarTypes0, ClassContext, TVarMap, TCVarMap,
+ VarSet0, Markers, ModuleInfo0, ModuleInfo, PredProcId) :-
Goal0 = _GoalExpr - GoalInfo,
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
@@ -856,13 +858,15 @@
globals__lookup_bool_option(Globals, typeinfo_liveness,
TypeInfoLiveness),
( TypeInfoLiveness = yes ->
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap,
- VarTypes0, ExistQVars, Goal0, ExtraTypeInfos0),
- set__delete_list(ExtraTypeInfos0, ArgVars0, ExtraTypeInfos),
- set__to_sorted_list(ExtraTypeInfos, ExtraArgs),
- list__append(ExtraArgs, ArgVars0, ArgVars)
+ VarTypes0, ExistQVars, NonLocals, ExtraTypeInfos0),
+ set__delete_list(ExtraTypeInfos0, ArgVars0, ExtraTypeInfos1),
+ set__to_sorted_list(ExtraTypeInfos1, ExtraTypeInfos),
+ list__append(ExtraTypeInfos, ArgVars0, ArgVars)
;
- ArgVars = ArgVars0
+ ArgVars = ArgVars0,
+ ExtraTypeInfos = []
),
goal_info_get_context(GoalInfo, Context),
@@ -1151,6 +1155,10 @@
map(class_constraint, var),
% typeclass_info vars for class
% constraints
+ % Note that this field is not looked
+ % at after polymorphism is run, and
+ % is created by polymorphism, so it
+ % is probably redundant.
eval_method, % how should the proc be evaluated
maybe(arg_size_info),
% Information about the relative sizes
Index: compiler/inlining.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/inlining.m,v
retrieving revision 1.78
diff -u -t -u -r1.78 inlining.m
--- inlining.m 1998/07/08 20:56:25 1.78
+++ inlining.m 1998/08/16 23:37:31
@@ -107,6 +107,15 @@
:- mode inlining__do_inline_call(in, in, in, in, in, out, in, out,
in, out, in, out, out) is det.
+ % inlining__get_type_substitution(CalleeArgTypes, CallerArgTypes,
+ % HeadTypeParams, CalleeExistQTVars, TypeSubn).
+ %
+ % Work out a type substitution to map the callee's argument
+ % types into the caller's.
+:- pred inlining__get_type_substitution(list(type), list(type),
+ head_type_params, list(tvar), map(tvar, type)).
+:- mode inlining__get_type_substitution(in, in, in, in, out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -523,7 +535,8 @@
% we may need to bind type variables in the caller.
% For example, if we call `:- pred some [T] foo(T)',
% and the definition of `foo' binds `T' to `int',
- % then we need
+ % then we need to replace all occurrences of type `T'
+ % with type `int' in the caller.
% first, rename apart the type variables in the callee.
% (we can almost throw away the new typevarset, since we
@@ -539,7 +552,7 @@
% next, compute the type substitution and then apply it
% Note: there's no need to update the type_info locations maps,
- % either for the caller or calle, since for any type vars in the
+ % either for the caller or callee, since for any type vars in the
% callee which get bound to type vars in the caller, the type_info
% location will be given by the entry in the caller's
% type_info locations map (and vice versa). It doesn't matter if the
@@ -550,49 +563,24 @@
map__apply_to_list(HeadVars, CalleeVarTypes1, HeadTypes),
map__apply_to_list(ArgVars, VarTypes0, ArgTypes),
- % handle the common case of non-existentially specially,
- % since we can do things more efficiently in that case
pred_info_get_exist_quant_tvars(PredInfo, CalleeExistQVars),
+ inlining__get_type_substitution(HeadTypes, ArgTypes, HeadTypeParams,
+ CalleeExistQVars, TypeSubn),
+
+ % handle the common case of non-existentially typed preds specially,
+ % since we can do things more efficiently in that case
( CalleeExistQVars = [] ->
- (
- type_list_subsumes(HeadTypes, ArgTypes, TypeSubn)
- ->
% update types in callee only
apply_rec_substitution_to_type_map(CalleeVarTypes1,
TypeSubn, CalleeVarTypes),
VarTypes1 = VarTypes0
- ;
- % The head types should always be unifiable with the
- % actual argument types, otherwise it is a type error
- % that should have been detected by typechecking.
- % But polymorphism.m introduces type-incorrect code --
- % e.g. compare(Res, EnumA, EnumB) gets converted
- % into builtin_compare_int(Res, EnumA, EnumB), which
- % is a type error since it assumes that an enumeration
- % is an int. In those cases, we don't need to
- % worry about the type substitution.
- % (Perhaps it would be better if polymorphism introduced
- % calls to unsafe_type_cast/2 for such cases.)
- CalleeVarTypes = CalleeVarTypes1,
- VarTypes1 = VarTypes0
- )
;
- % for calls to existentially type preds, we may need to
- % bind type variables in the caller, not just those in the callee
- (
- map__init(TypeSubn0),
- type_unify_list(HeadTypes, ArgTypes, HeadTypeParams,
- TypeSubn0, TypeSubn)
- ->
% update types in callee
apply_rec_substitution_to_type_map(CalleeVarTypes1,
TypeSubn, CalleeVarTypes),
% update types in caller
apply_rec_substitution_to_type_map(VarTypes0,
TypeSubn, VarTypes1)
- ;
- error("inlining.m: type unification failed")
- )
),
% Now rename apart the variables in the called goal.
@@ -604,9 +592,43 @@
goal_util__must_rename_vars_in_goal(CalledGoal, Subn, Goal),
apply_substitutions_to_var_map(CalleeTypeInfoVarMap0,
- TypeRenaming, Subn, CalleeTypeInfoVarMap1),
+ TypeRenaming, TypeSubn, Subn, CalleeTypeInfoVarMap1),
map__merge(TypeInfoVarMap0, CalleeTypeInfoVarMap1,
TypeInfoVarMap).
+
+inlining__get_type_substitution(HeadTypes, ArgTypes,
+ HeadTypeParams, CalleeExistQVars, TypeSubn) :-
+ ( CalleeExistQVars = [] ->
+ ( type_list_subsumes(HeadTypes, ArgTypes, TypeSubn0) ->
+ TypeSubn = TypeSubn0
+ ;
+ % The head types should always be unifiable with the
+ % actual argument types, otherwise it is a type error
+ % that should have been detected by typechecking.
+ % But polymorphism.m introduces type-incorrect code --
+ % e.g. compare(Res, EnumA, EnumB) gets converted
+ % into builtin_compare_int(Res, EnumA, EnumB), which
+ % is a type error since it assumes that an enumeration
+ % is an int. In those cases, we don't need to
+ % worry about the type substitution.
+ % (Perhaps it would be better if polymorphism introduced
+ % calls to unsafe_type_cast/2 for such cases.)
+ map__init(TypeSubn)
+ )
+ ;
+ % for calls to existentially type preds, we may need to
+ % bind type variables in the caller, not just those in
+ % the callee
+ (
+ map__init(TypeSubn0),
+ type_unify_list(HeadTypes, ArgTypes, HeadTypeParams,
+ TypeSubn0, TypeSubn1)
+ ->
+ TypeSubn = TypeSubn1
+ ;
+ error("inlining.m: type unification failed")
+ )
+ ).
%-----------------------------------------------------------------------------%
Index: compiler/lambda.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/lambda.m,v
retrieving revision 1.44
diff -u -t -u -r1.44 lambda.m
--- lambda.m 1998/07/08 20:56:33 1.44
+++ lambda.m 1998/08/12 03:30:32
@@ -91,7 +91,7 @@
:- import_module make_hlds, globals, options.
:- import_module goal_util, prog_util, mode_util, inst_match, llds, arg_info.
-:- import_module bool, string, std_util, require.
+:- import_module assoc_list, bool, string, std_util, require.
:- type lambda_info --->
lambda_info(
@@ -273,8 +273,10 @@
% XXX existentially typed lambda expressions are not yet supported
% (see the documentation at top of this file)
ExistQVars = [],
+ LambdaGoal = _ - LambdaGoalInfo,
+ goal_info_get_nonlocals(LambdaGoalInfo, LambdaNonLocals),
goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap, VarTypes,
- ExistQVars, LambdaGoal, ExtraTypeInfos),
+ ExistQVars, LambdaNonLocals, ExtraTypeInfos),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals0, ExtraTypeInfos, LambdaGoal, Unification0,
VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
@@ -411,7 +413,7 @@
map__from_corresponding_lists(OrigVars, OrigArgModes,
OrigArgModesMap),
map__overlay(ArgModesMap, OrigArgModesMap, ArgModesMap1),
- map__values(ArgModesMap1, ArgModes1),
+ map__apply_to_list(ArgVars, ArgModesMap1, ArgModes1),
% Recompute the uni_modes.
mode_util__modes_to_uni_modes(ArgModes1, ArgModes1,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.105
diff -u -t -u -r1.105 mercury_compile.m
--- mercury_compile.m 1998/07/27 01:04:43 1.105
+++ mercury_compile.m 1998/08/12 06:45:19
@@ -1560,12 +1560,15 @@
is det.
mercury_compile__maybe_higher_order(HLDS0, Verbose, Stats, HLDS) -->
- globals__io_lookup_bool_option(optimize_higher_order, Optimize),
- ( { Optimize = yes } ->
+ globals__io_lookup_bool_option(optimize_higher_order, HigherOrder),
+ globals__io_lookup_bool_option(type_specialization, Types),
+
+ ( { HigherOrder = yes ; Types = yes } ->
maybe_write_string(Verbose,
- "% Specializing higher-order predicates...\n"),
+ "% Specializing higher-order and polymorphic predicates...\n"),
maybe_flush_output(Verbose),
- specialize_higher_order(HLDS0, HLDS),
+
+ specialize_higher_order(HigherOrder, Types, HLDS0, HLDS),
maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats)
;
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.143
diff -u -t -u -r1.143 mercury_to_mercury.m
--- mercury_to_mercury.m 1998/08/19 06:51:12 1.143
+++ mercury_to_mercury.m 1998/08/25 04:29:24
@@ -1034,7 +1034,8 @@
{ string__int_to_string(Arity, ArityString) },
io__write_strings(["<base_type_info for ",
ModuleString, ":", Type, "/", ArityString, ">"]).
-mercury_output_cons_id(base_typeclass_info_const(Module, Class, InstanceString),
+mercury_output_cons_id(
+ base_typeclass_info_const(Module, Class, _, InstanceString),
_) -->
{ prog_out__sym_name_to_string(Module, ModuleString) },
io__write_string("<base_typeclass_info for "),
@@ -1461,7 +1462,7 @@
:- mode output_type(in, in, di, uo) is det.
output_type(VarSet, Type) -->
- mercury_output_term(Type, VarSet, no).
+ mercury_output_term(Type, VarSet, yes).
%-----------------------------------------------------------------------------%
Index: compiler/options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/options.m,v
retrieving revision 1.239
diff -u -t -u -r1.239 options.m
--- options.m 1998/08/10 06:56:41 1.239
+++ options.m 1998/08/26 07:24:45
@@ -217,6 +217,8 @@
; optimize_unused_args
; intermod_unused_args
; optimize_higher_order
+ ; type_specialization
+ ; higher_order_size_limit
; optimize_constructor_last_call
; optimize_duplicate_calls
; constant_propagation
@@ -533,6 +535,8 @@
optimize_unused_args - bool(no),
intermod_unused_args - bool(no),
optimize_higher_order - bool(no),
+ type_specialization - bool(no),
+ higher_order_size_limit - int(20),
optimize_constructor_last_call - bool(no),
optimize_dead_procs - bool(no),
deforestation - bool(no),
@@ -835,6 +839,9 @@
long_option("intermod-unused-args", intermod_unused_args).
long_option("optimize-higher-order", optimize_higher_order).
long_option("optimise-higher-order", optimize_higher_order).
+long_option("type-specialization", type_specialization).
+long_option("type-specialisation", type_specialization).
+long_option("higher-order-size-limit", higher_order_size_limit).
long_option("optimise-constructor-last-call", optimize_constructor_last_call).
long_option("optimize-constructor-last-call", optimize_constructor_last_call).
long_option("optimize-dead-procs", optimize_dead_procs).
@@ -1144,7 +1151,7 @@
optimize_saved_vars - bool(yes),
optimize_unused_args - bool(yes),
optimize_higher_order - bool(yes),
- %deforestation - bool(yes), % causes an abort
+ deforestation - bool(yes),
constant_propagation - bool(yes),
optimize_repeat - int(4)
]).
@@ -1798,7 +1805,12 @@
"\t`--intermodule-optimization'.",
"--optimize-higher-order",
- "\tEnable specialization higher-order predicates.",
+ "\tEnable specialization of higher-order predicates.",
+ "--type-specialization",
+ "\tEnable specialization of polymorphic predicates.",
+ "--higher-order-size-limit",
+ "\tSet the maximum goal size of specialized versions created by",
+ "\t--optimize-higher-order and --type-specialization.",
"--optimize-constructor-last-call",
"\tEnable the optimization of ""last"" calls that are followed by",
"\tconstructor application.",
Index: compiler/pd_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pd_info.m,v
retrieving revision 1.1
diff -u -t -u -r1.1 pd_info.m
--- pd_info.m 1998/04/27 04:02:03 1.1
+++ pd_info.m 1998/07/30 03:58:01
@@ -739,7 +739,9 @@
{ proc_info_vartypes(ProcInfo, VarTypes) },
{ proc_info_typeinfo_varmap(ProcInfo, TVarMap) },
{ proc_info_typeclass_info_varmap(ProcInfo, TCVarMap) },
- { hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap,
+ % XXX handle the extra typeinfo arguments for
+ % --typeinfo-liveness properly.
+ { hlds_pred__define_new_pred(Goal, CallGoal, Args, _ExtraArgs, InstMap,
Name, TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId) },
pd_info_set_module_info(ModuleInfo).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.147
diff -u -t -u -r1.147 polymorphism.m
--- polymorphism.m 1998/08/26 04:38:16 1.147
+++ polymorphism.m 1998/08/26 07:28:49
@@ -197,24 +197,24 @@
% :- instance foo(list(T)) <= foo(T) where [...].
%
% The typeclass_info for foo(int) is:
-% The base_type_info:
+% The base_typeclass_info:
% * 0 (arity of the instance declaration)
% * pointer to method #1
% ...
% * pointer to method #n
%
-% The type_info:
+% The typeclass_info:
% * a pointer to the base typeclass info
% * type info for int
%
% The typeclass_info for foo(list(T)) is:
-% The base_type_info:
+% The base_typeclass_info:
% * 1 (arity of the instance declaration)
% * pointer to method #1
% ...
% * pointer to method #n
%
-% The type_info contains:
+% The typeclass_info contains:
% * a pointer to the base typeclass info
% * typeclass info for foo(T)
% * type info for list(T)
@@ -305,7 +305,7 @@
:- module polymorphism.
:- interface.
-:- import_module hlds_module, prog_data.
+:- import_module hlds_module, hlds_pred, prog_data, special_pred.
:- import_module io.
:- pred polymorphism__process_module(module_info, module_info,
@@ -318,17 +318,50 @@
% is much simpler to avoid introducing type_info arguments for it.
% Since both of these are really just assignment unifications, it
% is desirable to generate them inline.
+ % There are also some predicates in private_builtin.m to
+ % manipulate typeclass_infos which don't need their type_infos.
:- pred polymorphism__no_type_info_builtin(module_name, string, int).
:- mode polymorphism__no_type_info_builtin(in, in, out) is semidet.
+ % From the type of a typeclass_info variable find the class_constraint
+ % about which the variable carries information, failing if the
+ % type is not a valid typeclass_info type.
+:- pred polymorphism__typeclass_info_class_constraint((type),
+ class_constraint).
+:- mode polymorphism__typeclass_info_class_constraint(in, out) is semidet.
+
+ % From the type of a type_info variable find the type about which
+ % the type_info carries information, failing if the type is not a
+ % valid type_info type.
+:- pred polymorphism__type_info_type((type), (type)).
+:- mode polymorphism__type_info_type(in, out) is semidet.
+
+ % 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.
+:- pred polymorphism__is_typeclass_info_manipulator(module_info,
+ pred_id, typeclass_info_manipulator).
+:- mode polymorphism__is_typeclass_info_manipulator(in, in, out) is semidet.
+
+:- type typeclass_info_manipulator
+ ---> type_info_from_typeclass_info
+ ; superclass_from_typeclass_info
+ .
+
+ % Look up the pred_id and proc_id for a type specific
+ % unification/comparison/index predicate.
+:- pred polymorphism__get_special_proc(type, special_pred_id,
+ module_info, sym_name, pred_id, proc_id).
+:- mode polymorphism__get_special_proc(in, in, in, out, out, out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda).
-:- import_module type_util, mode_util, quantification, instmap.
-:- import_module code_util, unify_proc, special_pred, prog_util, make_hlds.
+:- import_module hlds_goal, hlds_data, llds, (lambda).
+:- import_module type_util, mode_util, quantification, instmap, prog_io.
+:- import_module code_util, unify_proc, prog_util, make_hlds.
:- import_module (inst), hlds_out, base_typeclass_info, goal_util, passes_aux.
:- import_module bool, int, string, list, set, map.
@@ -421,6 +454,12 @@
polymorphism__no_type_info_builtin(MercuryBuiltin,
"unsafe_promise_unique", 2) :-
mercury_public_builtin_module(MercuryBuiltin).
+polymorphism__no_type_info_builtin(MercuryBuiltin,
+ "superclass_from_typeclass_info", 3) :-
+ mercury_private_builtin_module(MercuryBuiltin).
+polymorphism__no_type_info_builtin(MercuryBuiltin,
+ "type_info_from_typeclass_info", 3) :-
+ mercury_private_builtin_module(MercuryBuiltin).
%---------------------------------------------------------------------------%
@@ -830,8 +869,7 @@
% We don't need to add type-infos for higher-order calls,
% since the type-infos are added when the closures are
- % constructed, not when they are called. (Or at least I
- % think we don't... -fjh.)
+ % constructed, not when they are called.
polymorphism__process_goal_expr(higher_order_call(A, B, C, D, E, F),
GoalInfo, higher_order_call(A, B, C, D, E, F) - GoalInfo)
--> [].
@@ -865,9 +903,8 @@
{ list__member(SpecialPredId, SpecialPredIds) }
->
{ poly_info_get_module_info(Info0, ModuleInfo) },
- { classify_type(Type, ModuleInfo, TypeCategory) },
- { polymorphism__get_special_proc(TypeCategory, Type,
- SpecialPredId, ModuleInfo, Name, PredId1, ProcId1) }
+ { polymorphism__get_special_proc(Type, SpecialPredId,
+ ModuleInfo, Name, PredId1, ProcId1) }
;
{ PredId1 = PredId0 },
{ ProcId1 = ProcId0 },
@@ -1042,9 +1079,9 @@
polymorphism__process_goal(B0, B),
polymorphism__process_goal(C0, C).
-polymorphism__process_goal_expr(pragma_c_code(IsRecursive, PredId0, ProcId0,
- ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode),
- GoalInfo, Goal) -->
+polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
+ { Goal0 = pragma_c_code(IsRecursive, PredId0, ProcId0,
+ ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode) },
polymorphism__process_call(PredId0, ProcId0, ArgVars0, GoalInfo,
PredId, ProcId, ArgVars, ExtraVars, CallGoalInfo, ExtraGoals),
@@ -1056,71 +1093,94 @@
=(Info0),
{ poly_info_get_module_info(Info0, ModuleInfo) },
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
- { pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
- PredArgTypes) },
+
+ { pred_info_module(PredInfo, PredModule) },
+ { pred_info_name(PredInfo, PredName) },
+ { pred_info_arity(PredInfo, PredArity) },
+
+
+ (
+ { polymorphism__no_type_info_builtin(PredModule,
+ PredName, PredArity) }
+ ->
+ { Goal = Goal0 - GoalInfo }
+ ;
+ { list__length(ExtraVars, NumExtraVars) },
+ { polymorphism__process_c_code(PredInfo, NumExtraVars,
+ OrigArgTypes0, OrigArgTypes, ArgInfo0, ArgInfo) },
+
+ %
+ % plug it all back together
+ %
+ { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
+ ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
+ { list__append(ExtraGoals, [Call], GoalList) },
+ { conj_list_to_goal(GoalList, GoalInfo, Goal) }
+ ).
+
+
+:- pred polymorphism__process_c_code(pred_info, int, list(type), list(type),
+ list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
+:- mode polymorphism__process_c_code(in, in, in, out, in, out) is det.
+
+polymorphism__process_c_code(PredInfo, NumExtraVars, OrigArgTypes0,
+ OrigArgTypes, ArgInfo0, ArgInfo) :-
+ pred_info_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
+ PredArgTypes),
% Find out which variables are constrained (so that we don't
% add type-infos for them.
- { pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)) },
- { GetConstrainedVars = lambda([ClassConstraint::in, CVars::out] is det,
+ pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)),
+ GetConstrainedVars = lambda([ClassConstraint::in, CVars::out] is det,
(
ClassConstraint = constraint(_, CTypes),
term__vars_list(CTypes, CVars)
)
- ) },
- { list__map(GetConstrainedVars, UnivCs, UnivVars0) },
- { list__condense(UnivVars0, UnivConstrainedVars) },
- { list__map(GetConstrainedVars, ExistCs, ExistVars0) },
- { list__condense(ExistVars0, ExistConstrainedVars) },
-
- { term__vars_list(PredArgTypes, PredTypeVars0) },
- { list__remove_dups(PredTypeVars0, PredTypeVars1) },
- { list__delete_elems(PredTypeVars1, UnivConstrainedVars,
- PredTypeVars2) },
- { list__delete_elems(PredTypeVars2, ExistConstrainedVars,
- PredTypeVars) },
+ ),
+ list__map(GetConstrainedVars, UnivCs, UnivVars0),
+ list__condense(UnivVars0, UnivConstrainedVars),
+ list__map(GetConstrainedVars, ExistCs, ExistVars0),
+ list__condense(ExistVars0, ExistConstrainedVars),
+
+ term__vars_list(PredArgTypes, PredTypeVars0),
+ list__remove_dups(PredTypeVars0, PredTypeVars1),
+ list__delete_elems(PredTypeVars1, UnivConstrainedVars,
+ PredTypeVars2),
+ list__delete_elems(PredTypeVars2, ExistConstrainedVars,
+ PredTypeVars),
% sanity check
- { list__length(ExtraVars, NV) },
- { list__length(UnivCs, NUCs) },
- { list__length(ExistCs, NECs) },
- { NCs is NUCs + NECs },
- { list__length(PredTypeVars, NTs) },
- { NEVs is NCs + NTs },
- { require(unify(NEVs, NV),
- "list length mismatch in polymorphism processing pragma_c") },
+ list__length(UnivCs, NUCs),
+ list__length(ExistCs, NECs),
+ NCs is NUCs + NECs,
+ list__length(PredTypeVars, NTs),
+ NEVs is NCs + NTs,
+ require(unify(NEVs, NumExtraVars),
+ "list length mismatch in polymorphism processing pragma_c"),
- { polymorphism__c_code_add_typeinfos(
+ polymorphism__c_code_add_typeinfos(
PredTypeVars, PredTypeVarSet, ExistQVars,
- ArgInfo0, ArgInfo1) },
- { polymorphism__c_code_add_typeclass_infos(
- UnivCs, ExistCs, PredTypeVarSet, ArgInfo1, ArgInfo) },
+ ArgInfo0, ArgInfo1),
+ polymorphism__c_code_add_typeclass_infos(
+ UnivCs, ExistCs, PredTypeVarSet, ArgInfo1, ArgInfo),
%
% insert type_info/typeclass_info types for all the inserted
% type_info/typeclass_info vars into the arg-types list
%
- { mercury_private_builtin_module(PrivateBuiltin) },
- { MakeType = lambda([TypeVar::in, TypeInfoType::out] is det,
+ mercury_private_builtin_module(PrivateBuiltin),
+ MakeType = lambda([TypeVar::in, TypeInfoType::out] is det,
construct_type(qualified(PrivateBuiltin, "type_info") - 1,
- [term__variable(TypeVar)], TypeInfoType)) },
- { list__map(MakeType, PredTypeVars, TypeInfoTypes) },
- { MakeTypeClass = lambda([_::in, TypeClassInfoType::out] is det,
+ [term__variable(TypeVar)], TypeInfoType)),
+ list__map(MakeType, PredTypeVars, TypeInfoTypes),
+ MakeTypeClass = lambda([_::in, TypeClassInfoType::out] is det,
construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0,
- [], TypeClassInfoType)) },
- { list__map(MakeTypeClass, UnivCs, UnivTypes) },
- { list__map(MakeTypeClass, ExistCs, ExistTypes) },
- { list__append(TypeInfoTypes, OrigArgTypes0, OrigArgTypes1) },
- { list__append(ExistTypes, OrigArgTypes1, OrigArgTypes2) },
- { list__append(UnivTypes, OrigArgTypes2, OrigArgTypes) },
-
- %
- % plug it all back together
- %
- { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
- ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
- { list__append(ExtraGoals, [Call], GoalList) },
- { conj_list_to_goal(GoalList, GoalInfo, Goal) }.
+ [], TypeClassInfoType)),
+ list__map(MakeTypeClass, UnivCs, UnivTypes),
+ list__map(MakeTypeClass, ExistCs, ExistTypes),
+ list__append(TypeInfoTypes, OrigArgTypes0, OrigArgTypes1),
+ list__append(ExistTypes, OrigArgTypes1, OrigArgTypes2),
+ list__append(UnivTypes, OrigArgTypes2, OrigArgTypes).
:- pred polymorphism__c_code_add_typeclass_infos(
list(class_constraint), list(class_constraint),
@@ -1286,7 +1346,7 @@
TypeSubst1) ->
TypeSubst = TypeSubst1
;
- error("polymorphism__process_call: type unification failed")
+ error("polymorphism__process_goal_expr: type unification failed")
),
apply_subst_to_constraints(Subst, PredClassContext0,
@@ -1474,12 +1534,12 @@
;
poly_info_get_varset(Info0, VarSet0),
poly_info_get_var_types(Info0, VarTypes0),
- goal_util__extra_nonlocal_typeinfos(TypeVarMap,
- TypeClassVarMap, VarTypes0, ExistQVars, Goal0,
- NewOutsideVars),
Goal0 = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
- set__union(NewOutsideVars, NonLocals, OutsideVars),
+ goal_util__extra_nonlocal_typeinfos(TypeVarMap,
+ TypeClassVarMap, VarTypes0, ExistQVars,
+ NonLocals, NewOutsideVars),
+ set__union(NonLocals, NewOutsideVars, OutsideVars),
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
OutsideVars, Goal, VarSet, VarTypes, _Warnings),
poly_info_set_varset_and_types(VarSet, VarTypes, Info0, Info)
@@ -1775,7 +1835,7 @@
polymorphism__construct_typeclass_info(
InstanceExtraTypeInfoVars,
InstanceExtraTypeClassInfoVars,
- ClassId, InstanceNum,
+ ClassId, NewC, InstanceNum,
ExistQVars,
Var, NewGoals,
Info2, Info),
@@ -1800,8 +1860,9 @@
% First create a variable to hold the new
% typeclass_info
unqualify_name(ClassName, ClassNameString),
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
- ClassNameString, Var, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(VarSet0,
+ VarTypes0, NewC, ClassNameString,
+ Var, VarSet1, VarTypes1),
MaybeVar = yes(Var),
MaybePredProcId = no,
@@ -1846,11 +1907,8 @@
% Work out which superclass typeclass_info to
% take
- ToTerm = lambda([TheVar::in, TheTerm::out] is det,
- (
- TheTerm = term__variable(TheVar)
- )),
- list__map(ToTerm, SubClassVars, SubClassVarTerms),
+ term__var_list_to_term_list(SubClassVars,
+ SubClassVarTerms),
(
type_list_subsumes(SubClassVarTerms,
SubClassTypes, SubTypeSubst0)
@@ -1884,18 +1942,22 @@
% inserting a call to
% superclass_from_typeclass_info in
% private_builtin.
+ % Note that superclass_from_typeclass_info
+ % does not need extra type_info arguments
+ % even though its declaration is polymorphic.
% Make the goal for the call
- varset__init(Empty),
+ varset__init(DummyTVarSet0),
+ varset__new_var(DummyTVarSet0, TCVar, DummyTVarSet),
mercury_private_builtin_module(PrivateBuiltin),
ExtractSuperClass = qualified(PrivateBuiltin,
"superclass_from_typeclass_info"),
construct_type(qualified(PrivateBuiltin,
- "typeclass_info") - 0,
- [], TypeClassInfoType),
+ "typeclass_info") - 1, [term__variable(TCVar)],
+ TypeClassInfoType),
construct_type(unqualified("int") - 0, [], IntType),
get_pred_id_and_proc_id(ExtractSuperClass, predicate,
- Empty,
+ DummyTVarSet,
[TypeClassInfoType, IntType, TypeClassInfoType],
ModuleInfo, PredId, ProcId),
Call = call(PredId, ProcId,
@@ -1921,12 +1983,13 @@
).
:- pred polymorphism__construct_typeclass_info(list(var), list(var), class_id,
- int, existq_tvars, var, list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, out, out,
- in, out) is det.
+ class_constraint, int, existq_tvars, var, list(hlds_goal),
+ poly_info, poly_info).
+:- mode polymorphism__construct_typeclass_info(in, in, in, in, in, in,
+ out, out, in, out) is det.
polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
- ClassId, InstanceNum, ExistQVars,
+ ClassId, Constraint, InstanceNum, ExistQVars,
NewVar, NewGoals, Info0, Info) :-
poly_info_get_module_info(Info0, ModuleInfo),
@@ -1956,15 +2019,15 @@
unqualify_name(ClassName, ClassNameString),
polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
- ClassNameString, BaseVar, VarSet1, VarTypes1),
-
- base_typeclass_info__make_instance_string(InstanceTypes,
- InstanceString),
+ Constraint, ClassNameString, BaseVar, VarSet1, VarTypes1),
% XXX I don't think we actually need to carry the module name
% around.
ModuleName = unqualified("some bogus module name"),
- ConsId = base_typeclass_info_const(ModuleName, ClassId, InstanceString),
+ base_typeclass_info__make_instance_string(InstanceTypes,
+ InstanceString),
+ ConsId = base_typeclass_info_const(ModuleName, ClassId,
+ InstanceNum, InstanceString),
BaseTypeClassInfoTerm = functor(ConsId, []),
% create the construction unification to initialize the variable
@@ -1993,7 +2056,7 @@
% introduce a new variable
polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
- ClassNameString, NewVar, VarSet, VarTypes),
+ Constraint, ClassNameString, NewVar, VarSet, VarTypes),
% create the construction unification to initialize the
% variable
@@ -2018,7 +2081,7 @@
% note that we could perhaps be more accurate than
% `ground(shared)', but it shouldn't make any
% difference.
- InstConsId = cons( qualified(PrivateBuiltin, "typeclass_info"),
+ InstConsId = cons(qualified(PrivateBuiltin, "typeclass_info"),
NumArgVars),
instmap_delta_from_assoc_list(
[NewVar -
@@ -2373,12 +2436,9 @@
CountUnifyGoal = CountUnify - CountGoalInfo.
-:- pred polymorphism__get_special_proc(builtin_type, type, special_pred_id,
- module_info, sym_name, pred_id, proc_id).
-:- mode polymorphism__get_special_proc(in, in, in, in, out, out, out) is det.
-
-polymorphism__get_special_proc(TypeCategory, Type, SpecialPredId, ModuleInfo,
+polymorphism__get_special_proc(Type, SpecialPredId, ModuleInfo,
PredName, PredId, ProcId) :-
+ classify_type(Type, ModuleInfo, TypeCategory),
( TypeCategory = user_type ->
module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
( type_to_type_id(Type, TypeId, _TypeArgs) ->
@@ -2432,7 +2492,7 @@
->
PredId = PredId1
;
- error("polymorphism__get_pred_id: pred_id lookup failed")
+ error("polymorphism__get_builtin_pred_id: pred_id lookup failed")
).
% Create a unification for a type_info or base_type_info variable:
@@ -2588,7 +2648,7 @@
varset__name_var(VarSet1, Var, Name, VarSet),
mercury_private_builtin_module(PrivateBuiltin),
construct_type(qualified(PrivateBuiltin, Symbol) - 1, [Type],
- UnifyPredType),
+ UnifyPredType),
map__set(VarTypes0, Var, UnifyPredType, VarTypes).
%---------------------------------------------------------------------------%
@@ -2615,59 +2675,57 @@
:- mode extract_type_info_2(in, in, in, in, in, out, out, in, in, in, out, out,
out) is det.
-extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
+extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns) :-
% We need a tvarset to pass to get_pred_id_and_proc_id
- varset__init(TVarSet0),
- varset__new_var(TVarSet0, TVar, TVarSet),
+ varset__init(DummyTVarSet0),
mercury_private_builtin_module(PrivateBuiltin),
ExtractTypeInfo = qualified(PrivateBuiltin,
"type_info_from_typeclass_info"),
- construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0, [],
- TypeClassInfoType),
+
+ % We pretend that the `constraint' field of the
+ % `typeclass_info' type is a type variable for the purposes of
+ % locating `private_builtin:type_info_from_typeclass_info'.
+ varset__new_var(DummyTVarSet0, DummyTypeClassTVar, DummyTVarSet1),
+ construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
+ [term__variable(DummyTypeClassTVar)], TypeClassInfoType),
+
construct_type(unqualified("int") - 0, [], IntType),
+
+ varset__new_var(DummyTVarSet1, DummyTVar, DummyTVarSet),
construct_type(qualified(PrivateBuiltin, "type_info") - 1,
- [term__variable(TVar)], TypeInfoType),
- get_pred_id_and_proc_id(ExtractTypeInfo, predicate, TVarSet,
+ [term__variable(DummyTVar)], TypeInfoType),
+ get_pred_id_and_proc_id(ExtractTypeInfo, predicate, DummyTVarSet,
[TypeClassInfoType, IntType, TypeInfoType],
ModuleInfo, PredId, ProcId),
+
polymorphism__make_count_var(Index, VarSet0, VarTypes0, IndexVar,
IndexGoal, VarSet1, VarTypes1),
polymorphism__new_type_info_var(Type, "type_info", VarSet1, VarTypes1,
- TypeInfoVar, VarSet2, VarTypes2),
+ TypeInfoVar, VarSet, VarTypes),
- % We have to put an extra type_info at the front of the call to
- % type_info_from_typeclass_info, and pass it a bogus value
- % because the pred has a type parameter... even though we are
- % actually _extracting_ the type_info. Existential typing of
- % type_info_from_typeclass_info would fix this.
- polymorphism__new_type_info_var(Type, "type_info", VarSet2, VarTypes2,
- DummyTypeInfoVar, VarSet, VarTypes),
-
- % Now we put a dummy value in the dummy type-info variable.
- polymorphism__init_with_int_constant(DummyTypeInfoVar, 0,
- DummyTypeInfoGoal),
-
- % Make the goal info for the call
- set__list_to_set([DummyTypeInfoVar, TypeClassInfoVar, IndexVar,
- TypeInfoVar], NonLocals),
+ % Make the goal info for the call.
+ % `type_info_from_typeclass_info' does not require an extra
+ % type_info argument even though its declaration is
+ % polymorphic.
+ set__list_to_set([TypeClassInfoVar, IndexVar, TypeInfoVar], NonLocals),
instmap_delta_from_assoc_list([TypeInfoVar - ground(shared, no)],
InstmapDelta),
goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
Call = call(PredId, ProcId,
- [DummyTypeInfoVar, TypeClassInfoVar, IndexVar, TypeInfoVar],
+ [TypeClassInfoVar, IndexVar, TypeInfoVar],
not_builtin, no, ExtractTypeInfo) - GoalInfo,
- Goals = [IndexGoal, DummyTypeInfoGoal, Call],
+ Goals = [IndexGoal, Call],
% Update the location of the type_info so that we don't go to
% the bother of re-extracting it.
- map__det_update(TypeInfoLocns0, TVar, type_info(TypeInfoVar),
+ map__det_update(TypeInfoLocns0, TypeVar, type_info(TypeInfoVar),
TypeInfoLocns).
%-----------------------------------------------------------------------------%
@@ -2715,8 +2773,8 @@
% Make a new variable to contain the dictionary for this
% typeclass constraint
- polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
- Var, VarSet1, VarTypes1),
+ polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, C,
+ ClassName, Var, VarSet1, VarTypes1),
ExtraHeadVars1 = [Var | ExtraHeadVars0],
% Find all the type variables in the constraint, and remember
@@ -2769,21 +2827,74 @@
is_pair(_).
:- pred polymorphism__new_typeclass_info_var(varset, map(var, type),
- string, var,
+ class_constraint, string, var,
varset, map(var, type)).
-:- mode polymorphism__new_typeclass_info_var(in, in, in, out, out, out) is det.
+:- mode polymorphism__new_typeclass_info_var(in, in,
+ in, in, out, out, out) is det.
-polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
- Var, VarSet, VarTypes) :-
+polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, Constraint,
+ ClassString, Var, VarSet, VarTypes) :-
% introduce new variable
varset__new_var(VarSet0, Var, VarSet1),
- string__append("TypeClassInfo_for_", ClassName, Name),
+ string__append("TypeClassInfo_for_", ClassString, Name),
varset__name_var(VarSet1, Var, Name, VarSet),
- mercury_private_builtin_module(PrivateBuiltin),
- construct_type(qualified(PrivateBuiltin, "typeclass_info") - 0,
- [], DictionaryType),
+ polymorphism__build_typeclass_info_type(Constraint, DictionaryType),
map__set(VarTypes0, Var, DictionaryType, VarTypes).
+
+:- pred polymorphism__build_typeclass_info_type(class_constraint, (type)).
+:- mode polymorphism__build_typeclass_info_type(in, out) is det.
+
+polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :-
+ Constraint = constraint(SymName, ArgTypes),
+
+ % `constraint/n' is not really a type - it is a representation of a
+ % class constraint about which a typeclass_info holds information.
+ % `type_util:type_to_type_id' treats it as a type variable.
+ construct_qualified_term(SymName, [], ClassNameTerm),
+ construct_qualified_term(unqualified("constraint"),
+ [ClassNameTerm | ArgTypes], ConstraintTerm),
+
+ mercury_private_builtin_module(PrivateBuiltin),
+ construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
+ [ConstraintTerm], DictionaryType).
+
+%---------------------------------------------------------------------------%
+
+polymorphism__typeclass_info_class_constraint(TypeClassInfoType, Constraint) :-
+ mercury_private_builtin_module(PrivateBuiltin),
+ type_to_type_id(TypeClassInfoType,
+ qualified(PrivateBuiltin, "typeclass_info") - 1,
+ [ConstraintTerm]),
+
+ % type_to_type_id fails on `constraint/n', so we use
+ % `sym_name_and_args' instead.
+ sym_name_and_args(ConstraintTerm, unqualified("constraint"),
+ [ClassNameTerm | ArgTypes]),
+ sym_name_and_args(ClassNameTerm, ClassName, []),
+ Constraint = constraint(ClassName, ArgTypes).
+
+polymorphism__type_info_type(TypeInfoType, Type) :-
+ mercury_private_builtin_module(PrivateBuiltin),
+ type_to_type_id(TypeInfoType,
+ qualified(PrivateBuiltin, "type_info") - 1,
+ [Type]).
+
+%---------------------------------------------------------------------------%
+
+polymorphism__is_typeclass_info_manipulator(ModuleInfo,
+ PredId, TypeClassManipulator) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ mercury_private_builtin_module(PrivateBuiltin),
+ pred_info_module(PredInfo, PrivateBuiltin),
+ pred_info_name(PredInfo, PredName),
+ (
+ PredName = "type_info_from_typeclass_info",
+ TypeClassManipulator = type_info_from_typeclass_info
+ ;
+ PredName = "superclass_from_typeclass_info",
+ TypeClassManipulator = superclass_from_typeclass_info
+ ).
%---------------------------------------------------------------------------%
Index: compiler/special_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/special_pred.m,v
retrieving revision 1.22
diff -u -t -u -r1.22 special_pred.m
--- special_pred.m 1998/05/25 21:48:55 1.22
+++ special_pred.m 1998/08/17 04:52:46
@@ -96,11 +96,16 @@
special_pred_get_type("__Unify__", Types, T) :-
list__reverse(Types, [T | _]).
+special_pred_get_type("unify", Types, T) :-
+ list__reverse(Types, [T | _]).
special_pred_get_type("__Index__", Types, T) :-
list__reverse(Types, [_, T | _]).
+special_pred_get_type("index", Types, T) :-
+ list__reverse(Types, [_, T | _]).
special_pred_get_type("__Compare__", Types, T) :-
list__reverse(Types, [T | _]).
-
+special_pred_get_type("compare", Types, T) :-
+ list__reverse(Types, [T | _]).
special_pred_description(unify, "unification predicate").
special_pred_description(compare, "comparison predicate").
Index: compiler/type_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/type_util.m,v
retrieving revision 1.57
diff -u -t -u -r1.57 type_util.m
--- type_util.m 1998/08/04 02:14:13 1.57
+++ type_util.m 1998/08/25 00:55:44
@@ -157,15 +157,16 @@
map(var, type)).
:- mode apply_rec_substitution_to_type_map(in, in, out) is det.
- % Update a map from tvar to type_info_locn, using the type substititon
- % to rename tvars and a variable substition to rename vars.
+ % Update a map from tvar to type_info_locn, using the type renaming
+ % and substitution to rename tvars and a variable substition to
+ % rename vars.
%
% If tvar maps to a another type variable, we keep the new
% variable, if it maps to a type, we remove it from the map.
:- pred apply_substitutions_to_var_map(map(tvar, type_info_locn), tsubst,
- map(var, var), map(tvar, type_info_locn)).
-:- mode apply_substitutions_to_var_map(in, in, in, out) is det.
+ map(tvar, type), map(var, var), map(tvar, type_info_locn)).
+:- mode apply_substitutions_to_var_map(in, in, in, in, out) is det.
:- pred apply_rec_subst_to_constraints(substitution, class_constraints,
class_constraints).
@@ -247,36 +248,24 @@
% Given a type, determine what sort of type it is.
classify_type(VarType, ModuleInfo, Type) :-
- (
- VarType = term__variable(_)
- ->
- Type = polymorphic_type
- ;
- VarType = term__functor(term__atom("character"), [], _)
- ->
- Type = char_type
- ;
- VarType = term__functor(term__atom("int"), [], _)
- ->
- Type = int_type
- ;
- VarType = term__functor(term__atom("float"), [], _)
- ->
- Type = float_type
- ;
- VarType = term__functor(term__atom("string"), [], _)
- ->
- Type = str_type
- ;
- type_is_higher_order(VarType, _, _)
- ->
- Type = pred_type
- ;
- type_is_enumeration(VarType, ModuleInfo)
- ->
- Type = enum_type
+ ( type_to_type_id(VarType, TypeId, _) ->
+ ( TypeId = unqualified("character") - 0 ->
+ Type = char_type
+ ; TypeId = unqualified("int") - 0 ->
+ Type = int_type
+ ; TypeId = unqualified("float") - 0 ->
+ Type = float_type
+ ; TypeId = unqualified("string") - 0 ->
+ Type = str_type
+ ; type_id_is_higher_order(TypeId, _) ->
+ Type = pred_type
+ ; type_id_is_enumeration(TypeId, ModuleInfo) ->
+ Type = enum_type
+ ;
+ Type = user_type
+ )
;
- Type = user_type
+ Type = polymorphic_type
).
type_is_higher_order(Type, PredOrFunc, PredArgTypes) :-
@@ -304,11 +293,10 @@
PredOrFunc = function
).
-:- pred type_is_enumeration(type, module_info).
-:- mode type_is_enumeration(in, in) is semidet.
+:- pred type_id_is_enumeration(type_id, module_info).
+:- mode type_id_is_enumeration(in, in) is semidet.
-type_is_enumeration(Type, ModuleInfo) :-
- type_to_type_id(Type, TypeId, _),
+type_id_is_enumeration(TypeId, ModuleInfo) :-
module_info_types(ModuleInfo, TypeDefnTable),
map__search(TypeDefnTable, TypeId, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
@@ -318,6 +306,14 @@
type_to_type_id(Type, SymName - Arity, Args) :-
sym_name_and_args(Type, SymName, Args1),
+ % `private_builtin:constraint' is introduced by polymorphism, and
+ % should only appear as the argument of a `typeclass:info/1' type.
+ % It behaves sort of like a type variable, so according to the
+ % specification of `type_to_type_id', it should cause failure.
+ % There isn't a definition in the type table.
+ mercury_private_builtin_module(PrivateBuiltin),
+ SymName \= qualified(PrivateBuiltin, "constraint"),
+
% higher order types may have representations where
% their arguments don't directly correspond to the
% arguments of the term.
@@ -702,54 +698,77 @@
%-----------------------------------------------------------------------------%
-apply_substitutions_to_var_map(VarMap0, TSubst, Subst, VarMap) :-
+apply_substitutions_to_var_map(VarMap0, TRenaming, TSubst, Subst, VarMap) :-
% optimize the common case of empty substitutions
- ( map__is_empty(Subst), map__is_empty(TSubst) ->
+ (
+ map__is_empty(Subst),
+ map__is_empty(TSubst),
+ map__is_empty(TRenaming)
+ ->
VarMap = VarMap0
;
map__keys(VarMap0, TVars),
map__init(NewVarMap),
- apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst,
- Subst, NewVarMap, VarMap)
+ apply_substitutions_to_var_map_2(TVars, VarMap0,
+ TRenaming, TSubst, Subst, NewVarMap, VarMap)
).
:- pred apply_substitutions_to_var_map_2(list(var)::in, map(tvar,
- type_info_locn)::in, tsubst::in, map(var, var)::in,
- map(tvar, type_info_locn)::in,
+ type_info_locn)::in, tsubst::in, map(tvar, type)::in,
+ map(var, var)::in, map(tvar, type_info_locn)::in,
map(tvar, type_info_locn)::out) is det.
-apply_substitutions_to_var_map_2([], _VarMap0, _, _, NewVarMap, NewVarMap).
-apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TSubst, Subst,
- NewVarMap0, NewVarMap) :-
+apply_substitutions_to_var_map_2([], _VarMap0, _, _, _, NewVarMap, NewVarMap).
+apply_substitutions_to_var_map_2([TVar | TVars], VarMap0, TRenaming,
+ TSubst, VarSubst, NewVarMap0, NewVarMap) :-
map__lookup(VarMap0, TVar, Locn),
type_info_locn_var(Locn, Var),
+
+ % find the new var, if there is one
+ ( map__search(VarSubst, Var, NewVar0) ->
+ NewVar = NewVar0
+ ;
+ NewVar = Var
+ ),
+ type_info_locn_set_var(Locn, NewVar, NewLocn),
% find the new tvar, if there is one, otherwise just
% create the old var as a type variable.
- ( map__search(TSubst, TVar, NewTerm0) ->
- NewTerm = NewTerm0
+ (
+ map__search(TRenaming, TVar, NewTVar0)
+ ->
+ ( NewTVar0 = term__variable(NewTVar1) ->
+ NewTVar2 = NewTVar1
+ ;
+ % varset__merge_subst only returns var->var mappings,
+ % never var->term.
+ error(
+ "apply_substitution_to_var_map_2: weird type renaming")
+ )
;
- type_util__var(NewTerm, TVar)
+ % The variable wasn't renamed.
+ NewTVar2 = TVar
),
- % find the new var, if there is one
- ( map__search(Subst, Var, NewVar0) ->
- NewVar = NewVar0
+ ( map__search(TSubst, NewTVar2, NewType0) ->
+ NewType = NewType0
;
- NewVar = Var
+ % The variable wasn't substituted.
+ type_util__var(NewType, NewTVar2)
),
- type_info_locn_set_var(Locn, NewVar, NewLocn),
% if the tvar is still a variable, insert it into the
% map with the new var.
- ( type_util__var(NewTerm, NewTVar) ->
- map__det_insert(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
+ ( type_util__var(NewType, NewTVar) ->
+ % Don't abort if two old type variables
+ % map to the same new type variable.
+ map__set(NewVarMap0, NewTVar, NewLocn, NewVarMap1)
;
NewVarMap1 = NewVarMap0
),
- apply_substitutions_to_var_map_2(TVars, VarMap0, TSubst, Subst,
- NewVarMap1, NewVarMap).
+ apply_substitutions_to_var_map_2(TVars, VarMap0, TRenaming,
+ TSubst, VarSubst, NewVarMap1, NewVarMap).
%-----------------------------------------------------------------------------%
Index: compiler/unused_args.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/unused_args.m,v
retrieving revision 1.52
diff -u -t -u -r1.52 unused_args.m
--- unused_args.m 1998/07/08 20:57:41 1.52
+++ unused_args.m 1998/08/15 00:20:54
@@ -55,7 +55,7 @@
:- import_module hlds_pred, hlds_goal, hlds_data, hlds_out, type_util, instmap.
:- import_module code_util, globals, make_hlds, mercury_to_mercury, mode_util.
:- import_module options, prog_data, prog_out, quantification, special_pred.
-:- import_module passes_aux, inst_match, modules.
+:- import_module passes_aux, inst_match, modules, polymorphism.
:- import_module assoc_list, bool, char, int, list, map, require.
:- import_module set, std_util, string, term, varset.
@@ -258,7 +258,14 @@
module_info_globals(ModuleInfo, Globals),
globals__lookup_bool_option(Globals, typeinfo_liveness,
TypeinfoLiveness),
- ( TypeinfoLiveness = yes ->
+ (
+ TypeinfoLiveness = yes,
+ pred_info_module(PredInfo, PredModule),
+ pred_info_name(PredInfo, PredName),
+ pred_info_arity(PredInfo, PredArity),
+ \+ polymorphism__no_type_info_builtin(PredModule,
+ PredName, PredArity)
+ ->
proc_info_typeinfo_varmap(ProcInfo, TVarMap),
setup_typeinfo_deps(Vars, VarTypes,
proc(PredId, ProcId), TVarMap, VarDep2,
@@ -933,24 +940,24 @@
(
% fix up special pred names
special_pred_get_type(Name0, ArgTypes0, Type),
- type_to_type_id(Type, TypeId0, _)
+ type_to_type_id(Type, TypeId, _)
->
- TypeId = TypeId0
+ type_util__type_id_module(ModuleInfo,
+ TypeId, TypeModule),
+ type_util__type_id_name(ModuleInfo, TypeId, TypeName),
+ type_util__type_id_arity(ModuleInfo,
+ TypeId, TypeArity),
+ string__int_to_string(TypeArity, TypeAr),
+ prog_out__sym_name_to_string(TypeModule,
+ TypeModuleString0),
+ string__replace_all(TypeModuleString0, ":", "__",
+ TypeModuleString),
+ string__append_list([Name0, "_", TypeModuleString,
+ "__", TypeName, "_", TypeAr], Name1)
;
- string__append_list(["unused_args:make_new_pred_info\n",
- "cannot make label for special pred `",
- Name0, "'."], Message),
- error(Message)
- ),
- type_util__type_id_module(ModuleInfo, TypeId, TypeModule),
- type_util__type_id_name(ModuleInfo, TypeId, TypeName),
- type_util__type_id_arity(ModuleInfo, TypeId, TypeArity),
- string__int_to_string(TypeArity, TypeAr),
- prog_out__sym_name_to_string(TypeModule, TypeModuleString0),
- string__replace_all(TypeModuleString0, ":", "__",
- TypeModuleString),
- string__append_list( [Name0, "_", TypeModuleString, "__",
- TypeName, "_", TypeAr], Name1)
+ % The special predicate has already been specialised.
+ Name1 = Name0
+ )
;
Name1 = Name0
),
@@ -971,7 +978,6 @@
Markers, GoalType, PredOrFunc, ClassContext, EmptyProofs,
PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo).
-
% Replace the goal in the procedure with one to call the given
% pred_id and proc_id.
Index: user_guide.texi
===================================================================
RCS file: /home/staff/zs/imp/mercury/doc/user_guide.texi,v
retrieving revision 1.133
diff -u -t -u -r1.133 user_guide.texi
--- user_guide.texi 1998/08/10 07:17:09 1.133
+++ user_guide.texi 1998/08/30 05:33:23
@@ -2455,13 +2455,23 @@
@sp 1
@item --intermod-unused-args
Perform unused argument removal across module boundaries.
-This option implies `--optimize-unused-args' and
-`--intermodule-optimization'.
+This option implies @samp{--optimize-unused-args} and
+ at samp{--intermodule-optimization}.
@sp 1
@item --optimize-higher-order
Specialize calls to higher-order predicates where
the higher-order arguments are known.
+
+ at sp 1
+ at item --type-specialization
+Specialize calls to polymorphic predicates where
+the polymorphic types are known.
+
+ at sp 1
+ at item --higher-order-size-limit
+Set the maximum goal size of specialized versions created by
+ at samp{--optimize-higher-order} and @samp{--type-specialization}.
@sp 1
@item --optimize-constant-propagation
Index: library/private_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/private_builtin.m,v
retrieving revision 1.7
diff -u -t -u -r1.7 private_builtin.m
--- private_builtin.m 1998/08/24 08:24:23 1.7
+++ private_builtin.m 1998/08/25 04:29:42
@@ -89,12 +89,17 @@
:- type type_info(T) ---> type_info(base_type_info(T) /*, ... */).
:- type base_type_info(T) ---> base_type_info(int /*, ... */).
+ % The type variable in these types isn't really a type variable,
+ % it's a place for polymorphism.m to put a representation of the
+ % class constraint about which the typeclass_info carries information.
+ %
% Note that, since these types look to the compiler as though they
% are candidates to become no_tag types, special code is required in
% type_util:type_is_no_tag_type/3.
-:- type typeclass_info ---> typeclass_info(base_typeclass_info /*, ... */).
-:- type base_typeclass_info ---> typeclass_info(int /*, ... */).
+:- type typeclass_info(T) ---> typeclass_info(base_typeclass_info(T)
+ /*, ... */).
+:- type base_typeclass_info(_) ---> typeclass_info(int /*, ... */).
% type_info_from_typeclass_info(TypeClassInfo, Index, TypeInfo)
% extracts TypeInfo from TypeClassInfo, where TypeInfo is the Indexth
@@ -102,13 +107,14 @@
%
% Note: Index must be equal to the number of the desired type_info
% plus the number of superclasses for this class.
-:- pred type_info_from_typeclass_info(typeclass_info, int, type_info(T)).
+:- pred type_info_from_typeclass_info(typeclass_info(_), int, type_info(T)).
:- mode type_info_from_typeclass_info(in, in, out) is det.
% superclass_from_typeclass_info(TypeClassInfo, Index, SuperClass)
% extracts SuperClass from TypeClassInfo where TypeInfo is the Indexth
% superclass of the class.
-:- pred superclass_from_typeclass_info(typeclass_info, int, typeclass_info).
+:- pred superclass_from_typeclass_info(typeclass_info(_),
+ int, typeclass_info(_)).
:- mode superclass_from_typeclass_info(in, in, out) is det.
% the builtin < operator on ints, used in the code generated
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmakefile,v
retrieving revision 1.39
diff -u -t -u -r1.39 Mmakefile
--- Mmakefile 1998/08/26 07:51:56 1.39
+++ Mmakefile 1998/08/29 05:17:41
@@ -31,6 +31,7 @@
erroneous_liveness \
expand \
export_test \
+ extra_typeinfo \
float_map \
float_reg \
float_rounding_bug \
@@ -97,6 +98,9 @@
# some tests need to be compiled with particular options
MCFLAGS-boyer = --infer-all
+MCFLAGS-cut_test = -O5
+MCFLAGS-extra_typeinfo = --optimize-higher-order \
+ --no-type-specialization --typeinfo-liveness
MCFLAGS-func_test = --infer-all
MCFLAGS-ho_order = --optimize-higher-order
MCFLAGS-ho_order2 = --optimize-higher-order
%-----------------------------------------------------------------------------%
% This tests the inclusion and ordering of extra typeinfos by
% higher_order.m with --typeinfo-liveness.
% Unfortunately you really need to look at the HLDS dump to check this one.
% Compile this with options:
% --typeinfo-liveness --optimize-higher-order --no-type-specialization
% The --no-type-specialization is required to ensure that call_foldl
% remains polymorphic.
%-----------------------------------------------------------------------------%
:- module extra_typeinfo.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
:- import_module list.
main -->
( { call_foldl([[1,2,3], [4,5,6]], [[7,8,9], [10, 11, 12]], L) } ->
io__write(L),
io__nl
;
io__write_string("failed\n")
).
:- pred call_foldl(list(list(T))::in,
list(list(U))::in, list(list(U))::out) is semidet.
% This calls foldl so that the original type variables in foldl
% get mapped to non-variable types, so higher_order.m needs to add
% extra argument type_infos for the type variables in the types
% of the specialised arguments.
call_foldl(In, Out0, Out) :-
Pred = lambda([Int::in] is semidet, Int = 2),
list_foldl(Pred, [2], In, _, Out0, Out).
:- pred list_foldl(pred(V)::(pred(in) is semidet), list(V)::in,
T::in, T::out, U::in, U::out) is semidet.
list_foldl(_P, [], T, T, U, U).
list_foldl(P, [V | Vs], T0, T, U0, U) :-
call(P, V),
list_foldl(P, Vs, T0, T, U0, U).
%-----------------------------------------------------------------------------%
More information about the developers
mailing list