for review: type specialization [1]
Simon Taylor
stayl at cs.mu.OZ.AU
Thu Apr 15 15:37:47 AEST 1999
Hi Fergus,
This is an updated diff for the type specialization changes.
The main differences from last time are:
- user-guided type class specialization actually works this time.
- creation of unique names is done without threading counters through
everywhere (they're pretty ugly after mangling - I'll fix that later).
- somewhat more consistent use of `:- pragma ...' in error messages.
- it is not an error for a predicate and a function to both match
a `:- pragma type_spec' declaration - the names are distinguished
in the generated C code by the `fn__' prefix on the function.
- There's a new predicate in private_builtin.m to extract the
typeclass_infos for constraints on instance declarations.
- Added predicates to create goals to construct constants to hlds_goal.m.
- Test cases.
Thanks,
Simon.
Estimated hours taken: 60
User-guided type specialization.
compiler/prog_data.m:
compiler/prog_io_pragma.m:
compiler/modules.m:
compiler/module_qual.m:
compiler/mercury_to_mercury.m:
Handle `:- pragma type_spec'.
compiler/prog_io_pragma.m:
Factor out some common code to parse predicate names with arguments.
compiler/hlds_module.m:
Added a field to the module_sub_info to hold information about
user-requested type specializations, filled in by make_hlds.m
and not used by anything after higher_order.m.
compiler/make_hlds.m:
For each `:- pragma type_spec' declaration, introduce a new predicate
which just calls the predicate to be specialized with the
specified argument types. This forces higher_order.m to produce
the specialized versions.
compiler/higher_order.m:
Process the user-requested type specializations first to ensure
that they get the correct names.
Allow partial matches against user-specified versions, e.g.
map__lookup(map(int, list(int)), int, list(int)) matches
map__lookup(map(int, V), int, V).
Perform specialization where a typeclass constraint matches a
known instance, but the construction of the typeclass_info is
done in the calling module.
Give slightly more informative progress messages.
compiler/dead_proc_elim.m:
Remove specializations for dead procedures.
compiler/prog_util.m:
Change the definition of the `maybe1' and `maybe_functor' types
to avoid the need for copying to convert between `maybe1'
and `maybe1(generic)'.
Changed the interface of `make_pred_name_with_context' to allow
creation of predicate names for type specializations which describe
the type substitution.
compiler/make_hlds.m:
compiler/prog_io_pragma.m:
Make the specification of pragma declarations in error
messages consistent. (There are probably some more to
be fixed elsewhere for termination and tabling).
compiler/intermod.m:
Write type specialization pragmas for predicates declared
in `.opt' files.
compiler/mercury_to_mercury.m:
Export `mercury_output_item' for use by intermod.m.
compiler/options.m:
Add an option `--user-guided-type-specialization' enabled
with `-O3' or higher.
compiler/handle_options.m:
`--type-specialization' implies `--user-guided-type-specialization'.
compiler/hlds_goal.m:
Add predicates to construct constants. These are duplicated
in several other places, I'll fix that as a separate change.
compiler/type_util.m:
Added functions `int_type/0', `string_type/0', `float_type/0'
and `char_type/0' which return the builtin types.
These are duplicated in several other places,
I'll fix that as a separate change.
library/private_builtin.m:
Added `instance_constraint_from_typeclass_info/3' to extract
the typeclass_infos for a constraint on an instance declaration.
This is useful for specializing class method calls.
Added `thread_safe' to various `:- pragma c_code's.
Added `:- pragma inline' declarations for `builtin_compare_*', which
are important for user-guided type specialization. (`builtin_unify_*'
are simple enough to go in the `.opt' files automatically).
compiler/polymorphism.m:
`instance_constraint_from_typeclass_info/3' does not need type_infos.
Add `instance_constraint_from_typeclass_info/3' to the
list of `typeclass_info_manipulator's which higher_order.m
can interpret.
NEWS:
doc/reference_manual.texi:
doc/user_guide.texi
Document the pragma and new options.
tests/invalid/Mmakefile:
tests/invalid/type_spec.m:
tests/invalid/type_spec.err_exp:
Test error reporting for invalid type specializations.
tests/hard_coded/Mmakefile:
tests/invalid/type_spec.m:
tests/invalid/type_spec.exp:
Test type specialization.
Index: NEWS
===================================================================
RCS file: /home/staff/zs/imp/mercury/NEWS,v
retrieving revision 1.142
diff -u -u -r1.142 NEWS
--- NEWS 1999/03/31 04:42:42 1.142
+++ NEWS 1999/04/07 01:18:37
@@ -134,3 +134,8 @@
directories for both versions in their PATH, with the more recent one
first, of course.
+* We've added support for user-guided type specialization.
+
+ See the "Type specialization" section of the "Pragmas" chapter of the
+ Mercury Language Reference Manual for details.
+
Index: compiler/const_prop.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/const_prop.m,v
retrieving revision 1.9
diff -u -u -r1.9 const_prop.m
--- const_prop.m 1999/04/01 02:51:23 1.9
+++ const_prop.m 1999/04/08 02:22:39
@@ -392,16 +392,13 @@
%------------------------------------------------------------------------------%
+ % recompute_instmap_delta is run by simplify.m if anything changes,
+ % so the insts are not important here.
:- pred make_construction(pair(prog_var, inst), cons_id, hlds_goal_expr).
:- mode make_construction(in, in, out) is det.
-make_construction(Var - VarInst, ConsId, Goal) :-
- RHS = functor(ConsId, []),
- CInst = bound(unique, [functor(ConsId, [])]),
- Mode = (VarInst -> CInst) - (CInst -> CInst),
- Unification = construct(Var, ConsId, [], []),
- Context = unify_context(explicit, []),
- Goal = unify(Var, RHS, Mode, Unification, Context).
+make_construction(Var - _, ConsId, Goal) :-
+ make_const_construction(Var, ConsId, Goal - _).
%------------------------------------------------------------------------------%
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.45
diff -u -u -r1.45 dead_proc_elim.m
--- dead_proc_elim.m 1999/04/08 08:41:02 1.45
+++ dead_proc_elim.m 1999/04/09 06:59:23
@@ -687,12 +687,37 @@
list__foldl(dead_pred_elim_initialize, PredIds,
DeadInfo0, DeadInfo1),
dead_pred_elim_analyze(DeadInfo1, DeadInfo),
- DeadInfo = dead_pred_info(ModuleInfo1, _, _, NeededPreds, _),
+ DeadInfo = dead_pred_info(ModuleInfo1, _, _, NeededPreds2, _),
+
+ %
+ % If a predicate is not needed, predicates which were added in
+ % make_hlds.m to force type specialization are also not needed.
+ % Here we add in those which are needed.
+ %
+ module_info_type_spec_info(ModuleInfo1,
+ type_spec_info(TypeSpecProcs0, TypeSpecForcePreds0,
+ SpecMap0, PragmaMap0)),
+ set__to_sorted_list(NeededPreds2, NeededPredList2),
+ list__foldl(
+ lambda([NeededPred::in, AllPreds0::in, AllPreds::out] is det, (
+ ( map__search(SpecMap0, NeededPred, NewNeededPreds) ->
+ set__insert_list(AllPreds0, NewNeededPreds, AllPreds)
+ ;
+ AllPreds = AllPreds0
+ )
+ )), NeededPredList2, NeededPreds2, NeededPreds),
+ set__intersect(TypeSpecForcePreds0, NeededPreds, TypeSpecForcePreds),
+
+ module_info_set_type_spec_info(ModuleInfo1,
+ type_spec_info(TypeSpecProcs0, TypeSpecForcePreds,
+ SpecMap0, PragmaMap0),
+ ModuleInfo2),
+
set__list_to_set(PredIds, PredIdSet),
set__difference(PredIdSet, NeededPreds, DeadPreds),
set__to_sorted_list(DeadPreds, DeadPredList),
list__foldl(module_info_remove_predicate, DeadPredList,
- ModuleInfo1, ModuleInfo).
+ ModuleInfo2, ModuleInfo).
:- pred dead_pred_elim_add_entity(entity::in, queue(pred_id)::in,
queue(pred_id)::out, set(pred_id)::in, set(pred_id)::out) is det.
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/equiv_type.m,v
retrieving revision 1.18
diff -u -u -r1.18 equiv_type.m
--- equiv_type.m 1999/02/12 03:46:53 1.18
+++ equiv_type.m 1999/03/19 04:03:37
@@ -36,9 +36,8 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module bool, require, std_util, map.
+:- import_module assoc_list, bool, require, std_util, map, term, varset.
:- import_module hlds_data, type_util, prog_data, prog_util, prog_out.
-:- import_module term, varset.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -164,6 +163,12 @@
EqvMap, Constraints, VarSet1),
equiv_type__replace_in_type_list(Ts0, VarSet1, EqvMap, Ts, VarSet, _).
+equiv_type__replace_in_item(
+ pragma(type_spec(A, B, C, D, E, Subst0, VarSet0)),
+ EqvMap,
+ pragma(type_spec(A, B, C, D, E, Subst, VarSet)), no) :-
+ equiv_type__replace_in_subst(Subst0, VarSet0, EqvMap, Subst, VarSet).
+
:- pred equiv_type__replace_in_type_defn(type_defn, tvarset, eqv_map,
type_defn, tvarset, bool).
:- mode equiv_type__replace_in_type_defn(in, in, in, out, out, out) is semidet.
@@ -272,6 +277,18 @@
equiv_type__replace_in_class_method(_,
func_mode(A,B,C,D,E,F,G),
func_mode(A,B,C,D,E,F,G)).
+
+%-----------------------------------------------------------------------------%
+
+:- pred equiv_type__replace_in_subst(assoc_list(tvar, type), tvarset,
+ eqv_map, assoc_list(tvar, type), tvarset).
+:- mode equiv_type__replace_in_subst(in, in, in, out, out) is det.
+
+equiv_type__replace_in_subst([], VarSet, _EqvMap, [], VarSet).
+equiv_type__replace_in_subst([Var - Type0 | Subst0], VarSet0,
+ EqvMap, [Var - Type | Subst], VarSet) :-
+ equiv_type__replace_in_type(Type0, VarSet0, EqvMap, Type, VarSet1),
+ equiv_type__replace_in_subst(Subst0, VarSet1, EqvMap, Subst, VarSet).
%-----------------------------------------------------------------------------%
Index: compiler/handle_options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/handle_options.m,v
retrieving revision 1.71
diff -u -u -r1.71 handle_options.m
--- handle_options.m 1999/03/29 11:17:59 1.71
+++ handle_options.m 1999/03/30 01:30:53
@@ -407,6 +407,11 @@
[]
),
+ % If we are doing type-specialization, we may as well take
+ % advantage of the declarations supplied by the programmer.
+ option_implies(type_specialization, user_guided_type_specialization,
+ bool(yes)),
+
% --intermod-unused-args implies --intermodule-optimization and
% --optimize-unused-args.
option_implies(intermod_unused_args, intermodule_optimization,
Index: compiler/higher_order.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/higher_order.m,v
retrieving revision 1.50
diff -u -u -r1.50 higher_order.m
--- higher_order.m 1999/03/22 08:07:09 1.50
+++ higher_order.m 1999/04/15 02:17:11
@@ -26,13 +26,9 @@
:- interface.
:- import_module hlds_module.
-:- import_module bool, io.
+:- import_module io.
- % specialize_higher_order(DoHigherOrder, DoTypeInfos, Module0, Module).
- % DoHigherOrder is the value of `--optimize-higher-order'.
- % DoTypeInfos is the value of `--type-specialization'
-:- pred specialize_higher_order(bool::in, bool::in,
- module_info::in, module_info::out,
+:- pred specialize_higher_order(module_info::in, module_info::out,
io__state::di, io__state::uo) is det.
%-------------------------------------------------------------------------------
@@ -43,63 +39,129 @@
:- import_module code_util, globals, make_hlds, mode_util, goal_util.
:- import_module type_util, options, prog_data, prog_out, quantification.
:- import_module mercury_to_mercury, inlining, polymorphism, prog_util.
-:- import_module special_pred, term, varset.
+:- import_module special_pred, passes_aux.
-:- import_module assoc_list, char, int, list, map, require, set.
-:- import_module std_util, string.
+:- import_module assoc_list, bool, char, int, list, map, require, set.
+:- import_module std_util, string, varset, term.
% Iterate collecting requests and processing them until there
% are no more requests remaining.
-specialize_higher_order(DoHigherOrder, DoTypeInfos,
- ModuleInfo0, ModuleInfo) -->
+specialize_higher_order(ModuleInfo0, ModuleInfo) -->
+ globals__io_lookup_bool_option(optimize_higher_order, HigherOrder),
+ globals__io_lookup_bool_option(type_specialization, TypeSpec),
+ globals__io_lookup_bool_option(user_guided_type_specialization,
+ UserTypeSpec),
globals__io_lookup_int_option(higher_order_size_limit, SizeLimit),
- { Params = ho_params(DoHigherOrder, DoTypeInfos, SizeLimit) },
- { get_specialization_requests(Params, Requests, GoalSizes,
- ModuleInfo0, ModuleInfo1) },
+ globals__io_lookup_bool_option(typeinfo_liveness,
+ TypeInfoLiveness),
+ { Params = ho_params(HigherOrder, TypeSpec,
+ UserTypeSpec, SizeLimit, TypeInfoLiveness) },
{ map__init(NewPredMap) },
{ map__init(PredVarMap) },
{ NewPreds0 = new_preds(NewPredMap, PredVarMap) },
- process_requests(Params, Requests, GoalSizes, 1, _NextHOid,
- NewPreds0, _NewPreds, ModuleInfo1, ModuleInfo).
+ { map__init(GoalSizes0) },
+
+ { module_info_predids(ModuleInfo0, PredIds0) },
+ { module_info_type_spec_info(ModuleInfo0,
+ type_spec_info(_, UserSpecPreds, _, _)) },
+
+ %
+ % Make sure the user requested specializations are processed first,
+ % since we don't want to create more versions if one of these
+ % matches.
+ %
+ { set__list_to_set(PredIds0, PredIdSet0) },
+ { set__difference(PredIdSet0, UserSpecPreds, PredIdSet) },
+ { set__to_sorted_list(PredIdSet, PredIds) },
+ { set__init(Requests0) },
+ { set__to_sorted_list(UserSpecPreds, UserSpecPredList) },
+ { get_specialization_requests(Params, UserSpecPredList, NewPreds0,
+ Requests0, UserRequests, GoalSizes0, GoalSizes1,
+ ModuleInfo0, ModuleInfo1) },
+ process_requests(Params, UserRequests, Requests1,
+ GoalSizes1, GoalSizes2, 1, NextHOid,
+ NewPreds0, NewPreds1, ModuleInfo1, ModuleInfo2),
-:- pred process_requests(ho_params::in, set(request)::in, goal_sizes::in,
- int::in, int::out, new_preds::in, new_preds::out, module_info::in,
- module_info::out, io__state::di, io__state::uo) is det.
-
-process_requests(Params, Requests0, GoalSizes0, NextHOid0, NextHOid,
- NewPreds0, NewPreds, ModuleInfo1, ModuleInfo) -->
- { filter_requests(Params, ModuleInfo1,
- Requests0, GoalSizes0, Requests) },
+ %
+ % Process all other specialization until no more requests
+ % are generated.
+ %
+ { get_specialization_requests(Params, PredIds, NewPreds1,
+ Requests1, Requests, GoalSizes2, GoalSizes,
+ ModuleInfo2, ModuleInfo3) },
+ recursively_process_requests(Params, Requests, GoalSizes, _,
+ NextHOid, _, NewPreds1, _NewPreds, ModuleInfo3, ModuleInfo4),
+
+ % Remove the predicates which were used to force the production of
+ % user-requested type specializations, since they are not called
+ % from anywhere and are no longer needed.
+ { list__foldl(module_info_remove_predicate,
+ UserSpecPredList, ModuleInfo4, ModuleInfo) }.
+
+ % Process one lot of requests, returning requests for any
+ % new specializations made possible by the first lot.
+:- pred process_requests(ho_params::in, set(request)::in, set(request)::out,
+ goal_sizes::in, goal_sizes::out, int::in, int::out,
+ new_preds::in, new_preds::out, module_info::in, module_info::out,
+ io__state::di, io__state::uo) is det.
+
+process_requests(Params, Requests0, NewRequests,
+ GoalSizes0, GoalSizes, NextHOid0, NextHOid,
+ NewPreds0, NewPreds, ModuleInfo1, ModuleInfo) -->
+ filter_requests(Params, ModuleInfo1, Requests0, GoalSizes0, Requests),
(
{ Requests = [] }
->
{ ModuleInfo = ModuleInfo1 },
{ NextHOid = NextHOid0 },
- { NewPreds = NewPreds0 }
+ { NewPreds = NewPreds0 },
+ { GoalSizes = GoalSizes0 },
+ { set__init(NewRequests) }
;
{ set__init(PredProcsToFix0) },
- create_new_preds(Requests, NewPreds0, NewPreds1,
+ create_new_preds(Params, Requests, NewPreds0, NewPreds1,
[], NewPredList, PredProcsToFix0, PredProcsToFix,
- NextHOid0, NextHOid1, ModuleInfo1, ModuleInfo2),
+ NextHOid0, NextHOid, ModuleInfo1, ModuleInfo2),
{ set__to_sorted_list(PredProcsToFix, PredProcs) },
{ set__init(NewRequests0) },
{ create_specialized_versions(Params, NewPredList,
- NewPreds1, NewPreds2, NewRequests0, NewRequests,
+ NewPreds1, NewPreds, NewRequests0, NewRequests,
GoalSizes0, GoalSizes, ModuleInfo2, ModuleInfo3) },
- { fixup_preds(Params, PredProcs, NewPreds2,
+ { fixup_preds(Params, PredProcs, NewPreds,
ModuleInfo3, ModuleInfo4) },
{ NewPredList \= [] ->
% The dependencies have changed, so the
% dependency graph needs to rebuilt for
% inlining to work properly.
module_info_clobber_dependency_info(ModuleInfo4,
- ModuleInfo5)
+ ModuleInfo)
;
- ModuleInfo5 = ModuleInfo4
- },
- process_requests(Params, NewRequests, GoalSizes, NextHOid1,
- NextHOid, NewPreds2, NewPreds, ModuleInfo5, ModuleInfo)
+ ModuleInfo = ModuleInfo4
+ }
+ ).
+
+ % Process requests until there are no new requests to process.
+:- pred recursively_process_requests(ho_params::in, set(request)::in,
+ goal_sizes::in, goal_sizes::out, int::in, int::out,
+ new_preds::in, new_preds::out, module_info::in, module_info::out,
+ io__state::di, io__state::uo) is det.
+
+recursively_process_requests(Params, Requests0,
+ GoalSizes0, GoalSizes, NextHOid0, NextHOid,
+ NewPreds0, NewPreds, ModuleInfo0, ModuleInfo) -->
+ ( { set__empty(Requests0) } ->
+ { GoalSizes = GoalSizes0 },
+ { NextHOid = NextHOid0 },
+ { NewPreds = NewPreds0 },
+ { ModuleInfo = ModuleInfo0 }
+ ;
+ process_requests(Params, Requests0, NewRequests,
+ GoalSizes0, GoalSizes1, NextHOid0, NextHOid1,
+ NewPreds0, NewPreds1, ModuleInfo0, ModuleInfo1),
+ recursively_process_requests(Params, NewRequests,
+ GoalSizes1, GoalSizes, NextHOid1, NextHOid,
+ NewPreds1, NewPreds, ModuleInfo1, ModuleInfo)
).
%-------------------------------------------------------------------------------
@@ -115,7 +177,9 @@
list(type), % Extra typeinfo argument
% types required by
% --typeinfo-liveness.
- tvarset % caller's typevarset.
+ tvarset, % caller's typevarset.
+ bool % is this a user-requested
+ % specialization
).
% Stores cons_id, index in argument vector, number of
@@ -163,8 +227,8 @@
% previous iterations
% not changed by traverse_goal
pred_proc_id, % pred_proc_id of goal being traversed
- pred_info, % not changed by traverse_goal
- proc_info, % not changed by traverse_goal
+ pred_info, % pred_info of goal being traversed
+ proc_info, % proc_info of goal being traversed
module_info, % not changed by traverse_goal
ho_params,
changed
@@ -174,7 +238,9 @@
---> ho_params(
bool, % propagate higher-order constants.
bool, % propagate type-info constants.
- int % size limit on requested version.
+ bool, % user-guided type specialization.
+ int, % size limit on requested version.
+ bool % --typeinfo-liveness
).
:- type new_preds
@@ -199,7 +265,9 @@
% in requesting caller
list(type), % extra typeinfo argument
% types in requesting caller
- tvarset % caller's typevarset
+ tvarset, % caller's typevarset
+ bool % is this a user-specified type
+ % specialization
).
% Returned by traverse_goal.
@@ -208,26 +276,15 @@
; request % Need to check other procs
; unchanged. % Do nothing more for this predicate
-%-------------------------------------------------------------------------------
-:- pred get_specialization_requests(ho_params::in, set(request)::out,
+%-----------------------------------------------------------------------------%
+:- pred get_specialization_requests(ho_params::in, list(pred_id)::in,
+ new_preds::in, set(request)::in, set(request)::out, goal_sizes::in,
goal_sizes::out, module_info::in, module_info::out) is det.
-get_specialization_requests(Params, Requests, GoalSizes,
- ModuleInfo0, ModuleInfo) :-
- module_info_predids(ModuleInfo0, PredIds),
- map__init(GoalSizes0),
- set__init(Requests0),
- get_specialization_requests_2(Params, PredIds, Requests0, Requests,
- GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo).
-
-:- pred get_specialization_requests_2(ho_params::in, list(pred_id)::in,
- set(request)::in, set(request)::out, goal_sizes::in, goal_sizes::out,
- module_info::in, module_info::out) is det.
-
-get_specialization_requests_2(_Params, [], Requests, Requests, Sizes, Sizes,
- ModuleInfo, ModuleInfo).
-get_specialization_requests_2(Params, [PredId | PredIds], Requests0, Requests,
- GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo) :-
+get_specialization_requests(_Params, [], _NewPreds, Requests, Requests,
+ Sizes, Sizes, ModuleInfo, ModuleInfo).
+get_specialization_requests(Params, [PredId | PredIds], NewPreds, Requests0,
+ Requests, GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo) :-
module_info_preds(ModuleInfo0, Preds0),
map__lookup(Preds0, PredId, PredInfo0),
pred_info_non_imported_procids(PredInfo0, NonImportedProcs),
@@ -243,21 +300,18 @@
proc_info_goal(ProcInfo0, Goal0),
map__init(PredVars0),
% first time through we can only specialize call/N
- map__init(NewPredMap),
- map__init(PredVarMap),
- NewPreds0 = new_preds(NewPredMap, PredVarMap),
PredProcId = proc(PredId, ProcId),
- Info0 = info(PredVars0, Requests0, NewPreds0, PredProcId,
+ Info0 = info(PredVars0, Requests0, NewPreds, PredProcId,
PredInfo0, ProcInfo0, ModuleInfo0, Params, unchanged),
traverse_goal_0(Goal0, Goal1, Info0,
- info(_, Requests1,_,_,_,_,_,_, Changed)),
+ info(_, Requests1,_,_,PredInfo1,ProcInfo1,_,_, Changed)),
goal_size(Goal1, GoalSize),
map__set(GoalSizes0, PredId, GoalSize, GoalSizes1),
- proc_info_set_goal(ProcInfo0, Goal1, ProcInfo1),
+ proc_info_set_goal(ProcInfo1, Goal1, ProcInfo2),
(
Changed = changed
->
- requantify_proc(ProcInfo1, ProcInfo),
+ requantify_proc(ProcInfo2, ProcInfo),
map__det_update(Procs0, ProcId, ProcInfo, Procs1)
;
Procs1 = Procs0
@@ -266,9 +320,9 @@
(Changed = request ; Changed = changed)
->
traverse_other_procs(Params, PredId, ProcIds,
- ModuleInfo0, PredInfo0, Requests1, Requests2,
- Procs1, Procs),
- pred_info_set_procedures(PredInfo0, Procs, PredInfo),
+ ModuleInfo0, PredInfo1, PredInfo2, NewPreds,
+ Requests1, Requests2, Procs1, Procs),
+ pred_info_set_procedures(PredInfo2, Procs, PredInfo),
map__det_update(Preds0, PredId, PredInfo, Preds),
module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1)
;
@@ -276,41 +330,42 @@
Requests2 = Requests1
)
),
- get_specialization_requests_2(Params, PredIds, Requests2, Requests,
- GoalSizes1, GoalSizes, ModuleInfo1, ModuleInfo).
+ get_specialization_requests(Params, PredIds, NewPreds,
+ Requests2, Requests, GoalSizes1, GoalSizes,
+ ModuleInfo1, ModuleInfo).
% This is called when the first procedure of a pred was
% changed. It fixes up all the other procs, ignoring the
% goal_size and requests that come out, since that information
% has already been collected.
:- pred traverse_other_procs(ho_params::in, pred_id::in, list(proc_id)::in,
- module_info::in, pred_info::in, set(request)::in,
- set(request)::out, proc_table::in, proc_table::out) is det.
+ module_info::in, pred_info::in, pred_info::out,
+ new_preds::in, set(request)::in,
+ set(request)::out, proc_table::in, proc_table::out) is det.
-traverse_other_procs(_Params, _PredId, [], _Module, _PredInfo,
- Requests, Requests, Procs, Procs).
+traverse_other_procs(_Params, _PredId, [], _Module, PredInfo, PredInfo,
+ _, Requests, Requests, Procs, Procs).
traverse_other_procs(Params, PredId, [ProcId | ProcIds], ModuleInfo,
- PredInfo0, Requests0, Requests, Procs0, Procs) :-
+ PredInfo0, PredInfo, NewPreds,
+ Requests0, Requests, Procs0, Procs) :-
map__init(PredVars0),
- map__init(NewPredMap),
- map__init(PredVarMap),
- NewPreds0 = new_preds(NewPredMap, PredVarMap),
map__lookup(Procs0, ProcId, ProcInfo0),
proc_info_goal(ProcInfo0, Goal0),
- Info0 = info(PredVars0, Requests0, NewPreds0, proc(PredId, ProcId),
+ Info0 = info(PredVars0, Requests0, NewPreds, proc(PredId, ProcId),
PredInfo0, ProcInfo0, ModuleInfo, Params, unchanged),
traverse_goal_0(Goal0, Goal1, Info0,
- info(_, Requests1, _,_,_,_,_,_,_)),
- proc_info_headvars(ProcInfo0, HeadVars),
- proc_info_varset(ProcInfo0, Varset0),
- proc_info_vartypes(ProcInfo0, VarTypes0),
+ info(_, Requests1, _,_,PredInfo1,ProcInfo1,_,_,_)),
+ proc_info_headvars(ProcInfo1, HeadVars),
+ proc_info_varset(ProcInfo1, Varset0),
+ proc_info_vartypes(ProcInfo1, VarTypes0),
implicitly_quantify_clause_body(HeadVars, Goal1, Varset0, VarTypes0,
Goal, Varset, VarTypes, _),
- proc_info_set_goal(ProcInfo0, Goal, ProcInfo1),
- proc_info_set_varset(ProcInfo1, Varset, ProcInfo2),
- proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo),
+ proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
+ proc_info_set_varset(ProcInfo2, Varset, ProcInfo3),
+ proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo),
map__det_update(Procs0, ProcId, ProcInfo, Procs1),
- traverse_other_procs(Params, PredId, ProcIds, ModuleInfo, PredInfo0,
+ traverse_other_procs(Params, PredId, ProcIds, ModuleInfo,
+ PredInfo1, PredInfo, NewPreds,
Requests1, Requests, Procs1, Procs).
%-------------------------------------------------------------------------------
@@ -322,6 +377,7 @@
traverse_goal_0(Goal0, Goal, Info0, Info) :-
Info0 = info(_, B, NewPreds0, PredProcId, E, F, G, H, I),
NewPreds0 = new_preds(_, PredVarMap),
+
% Lookup the initial known bindings of the variables if this
% procedure is a specialised version.
( map__search(PredVarMap, PredProcId, PredVars) ->
@@ -359,15 +415,17 @@
% check whether this call could be specialized
traverse_goal(Goal0, Goal) -->
- { Goal0 = higher_order_call(Var, Args, _,_,_,_) - _ },
- maybe_specialize_higher_order_call(Var, no, Args, Goal0, Goal).
+ { Goal0 = higher_order_call(Var, Args, _,_,_,_) - GoalInfo },
+ maybe_specialize_higher_order_call(Var, no, Args, Goal0, Goals),
+ { conj_list_to_goal(Goals, GoalInfo, Goal) }.
% class_method_calls are treated similarly to
% higher_order_calls.
traverse_goal(Goal0, Goal) -->
- { Goal0 = class_method_call(Var, Method, Args,_,_,_) - _ },
+ { Goal0 = class_method_call(Var, Method, Args,_,_,_) - GoalInfo },
maybe_specialize_higher_order_call(Var, yes(Method), Args,
- Goal0, Goal).
+ Goal0, Goals),
+ { conj_list_to_goal(Goals, GoalInfo, Goal) }.
% check whether this call could be specialized
traverse_goal(Goal0, Goal) -->
@@ -553,35 +611,33 @@
:- pred is_interesting_cons_id(ho_params::in, cons_id::in) is semidet.
-is_interesting_cons_id(ho_params(_, yes, _),
+is_interesting_cons_id(ho_params(_, _, yes, _, _),
cons(qualified(Module, Name), _)) :-
mercury_private_builtin_module(Module),
( Name = "type_info"
; Name = "typeclass_info"
).
-is_interesting_cons_id(ho_params(yes, _, _), pred_const(_, _)).
-is_interesting_cons_id(ho_params(_, yes, _), type_ctor_info_const(_, _, _)).
-is_interesting_cons_id(ho_params(_, yes, _),
+is_interesting_cons_id(ho_params(yes, _, _, _, _), pred_const(_, _)).
+is_interesting_cons_id(ho_params(_, _, yes, _, _),
+ type_ctor_info_const(_, _, _)).
+is_interesting_cons_id(ho_params(_, _, yes, _, _),
base_typeclass_info_const(_, _, _, _)).
% We need to keep track of int_consts so we can interpret
% superclass_info_from_typeclass_info and typeinfo_from_typeclass_info.
% We don't specialize based on them.
-is_interesting_cons_id(ho_params(_, yes, _), int_const(_)).
+is_interesting_cons_id(ho_params(_, _, yes, _, _), int_const(_)).
% Process a higher-order call or class_method_call to see if it
% could possibly be specialized.
:- pred maybe_specialize_higher_order_call(prog_var::in, maybe(int)::in,
- list(prog_var)::in, hlds_goal::in, hlds_goal::out,
+ list(prog_var)::in, hlds_goal::in, list(hlds_goal)::out,
higher_order_info::in, higher_order_info::out) is det.
maybe_specialize_higher_order_call(PredVar, MaybeMethod, Args,
- Goal0 - GoalInfo, Goal - GoalInfo, Info0, Info) :-
- Info0 = info(PredVars, _Requests0, _NewPreds, _PredProcId,
- _CallerPredInfo, _CallerProcInfo, ModuleInfo, _, _),
+ Goal0 - GoalInfo, Goals, Info0, Info) :-
+ Info0 = info(PredVars, Requests0, NewPreds, PredProcId,
+ CallerPredInfo0, CallerProcInfo0, ModuleInfo, Params, Changed),
- %proc_info_vartypes(CallerProcInfo, VarTypes),
- %map__lookup(VarTypes, PredVar, PredVarType),
-
% We can specialize calls to call/N and class_method_call/N if
% the closure or typeclass_info has a known value.
(
@@ -620,27 +676,174 @@
hlds_class_proc(PredId, ProcId)),
list__append(InstanceConstraintArgs, Args, AllArgs)
;
- fail
+ fail
)
->
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- pred_info_module(PredInfo, ModuleName),
- pred_info_name(PredInfo, PredName),
- code_util__builtin_state(ModuleInfo, PredId, ProcId, Builtin),
-
- MaybeContext = no,
- Goal1 = call(PredId, ProcId, AllArgs,
- Builtin, MaybeContext,
- qualified(ModuleName, PredName)),
- higher_order_info_update_changed_status(changed, Info0, Info1),
- maybe_specialize_call(Goal1 - GoalInfo,
- Goal - _, Info1, Info)
+ construct_specialized_higher_order_call(ModuleInfo,
+ PredId, ProcId, AllArgs, GoalInfo, Goal, Info0, Info),
+ Goals = [Goal]
+ ;
+ % Handle a class method call where we know which instance
+ % is being used, but we haven't seen a construction for
+ % the typeclass_info. This can happen for user-guided
+ % typeclass specialization, because the type-specialized class
+ % constraint is still in the constraint list, so a
+ % typeclass_info is passed in by the caller rather than
+ % being constructed locally.
+ %
+ % The problem is that in importing modules we don't know
+ % which instance declarations are visible in the imported
+ % module, so we don't know which class constraints are
+ % redundant after type specialization.
+ MaybeMethod = yes(Method),
+
+ proc_info_vartypes(CallerProcInfo0, VarTypes),
+ map__lookup(VarTypes, PredVar, TypeClassInfoType),
+ polymorphism__typeclass_info_class_constraint(
+ TypeClassInfoType, ClassConstraint),
+ ClassConstraint = constraint(ClassName, ClassArgs),
+ list__length(ClassArgs, ClassArity),
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__lookup(InstanceTable, class_id(ClassName, ClassArity),
+ Instances),
+ pred_info_typevarset(CallerPredInfo0, TVarSet0),
+ find_matching_instance_method(Instances, Method,
+ ClassArgs, PredId, ProcId, InstanceConstraints,
+ TVarSet0, TVarSet)
+ ->
+ pred_info_set_typevarset(CallerPredInfo0,
+ TVarSet, CallerPredInfo),
+ % Pull out the argument typeclass_infos.
+ ( InstanceConstraints = [] ->
+ ExtraGoals = [],
+ CallerProcInfo = CallerProcInfo0,
+ AllArgs = Args
+ ;
+ mercury_private_builtin_module(PrivateBuiltin),
+ module_info_get_predicate_table(ModuleInfo, PredTable),
+ ExtractArgSymName = qualified(PrivateBuiltin,
+ "instance_constraint_from_typeclass_info"),
+ (
+ predicate_table_search_pred_sym_arity(
+ PredTable, ExtractArgSymName,
+ 3, [ExtractArgPredId0])
+ ->
+ ExtractArgPredId = ExtractArgPredId0
+ ;
+ error(
+ "higher_order.m: can't find `instance-constraint_from_typeclass_info'")
+ ),
+ hlds_pred__initial_proc_id(ExtractArgProcId),
+ get_arg_typeclass_infos(PredVar, ExtractArgPredId,
+ ExtractArgProcId, ExtractArgSymName,
+ InstanceConstraints, 1,
+ ExtraGoals, ArgTypeClassInfos,
+ CallerProcInfo0, CallerProcInfo),
+ list__append(ArgTypeClassInfos, Args, AllArgs)
+ ),
+ Info1 = info(PredVars, Requests0, NewPreds, PredProcId,
+ CallerPredInfo, CallerProcInfo, ModuleInfo,
+ Params, Changed),
+ construct_specialized_higher_order_call(ModuleInfo,
+ PredId, ProcId, AllArgs, GoalInfo, Goal, Info1, Info),
+ list__append(ExtraGoals, [Goal], Goals)
;
% non-specializable call/N or class_method_call/N
- Goal = Goal0,
+ Goals = [Goal0 - GoalInfo],
Info = Info0
).
+:- pred find_matching_instance_method(list(hlds_instance_defn)::in, int::in,
+ list(type)::in, pred_id::out, proc_id::out,
+ list(class_constraint)::out, tvarset::in, tvarset::out) is semidet.
+
+find_matching_instance_method([Instance | Instances], MethodNum,
+ ClassTypes, PredId, ProcId, Constraints, TVarSet0, TVarSet) :-
+ (
+ instance_matches(ClassTypes, Instance,
+ Constraints0, TVarSet0, TVarSet1)
+ ->
+ TVarSet = TVarSet1,
+ Constraints = Constraints0,
+ Instance = hlds_instance_defn(_, _, _,
+ _, _, yes(ClassInterface), _, _),
+ list__index1_det(ClassInterface, MethodNum,
+ hlds_class_proc(PredId, ProcId))
+ ;
+ find_matching_instance_method(Instances, MethodNum,
+ ClassTypes, PredId, ProcId, Constraints,
+ TVarSet0, TVarSet)
+ ).
+
+:- pred instance_matches(list(type)::in, hlds_instance_defn::in,
+ list(class_constraint)::out, tvarset::in, tvarset::out) is semidet.
+
+instance_matches(ClassTypes, Instance, Constraints, TVarSet0, TVarSet) :-
+ Instance = hlds_instance_defn(_, _, Constraints0,
+ InstanceTypes0, _, _, InstanceTVarSet, _),
+ varset__merge_subst(TVarSet0, InstanceTVarSet, TVarSet,
+ RenameSubst),
+ term__apply_substitution_to_list(InstanceTypes0,
+ RenameSubst, InstanceTypes),
+ type_list_subsumes(InstanceTypes, ClassTypes, Subst),
+ apply_subst_to_constraint_list(RenameSubst,
+ Constraints0, Constraints1),
+ apply_rec_subst_to_constraint_list(Subst,
+ Constraints1, Constraints).
+
+ % Build calls to
+ % `private_builtin:instance_constraint_from_typeclass_info/3'
+ % to extract the typeclass_infos for the constraints on an instance.
+ % This simulates the action of `do_call_*_class_method' in
+ % runtime/mercury_ho_call.c.
+:- pred get_arg_typeclass_infos(prog_var::in, pred_id::in, proc_id::in,
+ sym_name::in, list(class_constraint)::in, int::in,
+ list(hlds_goal)::out, list(prog_var)::out,
+ proc_info::in, proc_info::out) is det.
+
+get_arg_typeclass_infos(_, _, _, _, [], _, [], [], ProcInfo, ProcInfo).
+get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName,
+ [InstanceConstraint | InstanceConstraints],
+ ConstraintNum, [ConstraintNumGoal, CallGoal | Goals],
+ [ArgTypeClassInfoVar | Vars], ProcInfo0, ProcInfo) :-
+ polymorphism__build_typeclass_info_type(InstanceConstraint,
+ ArgTypeClassInfoType),
+ proc_info_create_var_from_type(ProcInfo0, ArgTypeClassInfoType,
+ ArgTypeClassInfoVar, ProcInfo1),
+ MaybeContext = no,
+ make_int_const_construction(ConstraintNum, ConstraintNumGoal,
+ ConstraintNumVar, ProcInfo1, ProcInfo2),
+ Args = [TypeClassInfoVar, ConstraintNumVar, ArgTypeClassInfoVar],
+
+ set__list_to_set(Args, NonLocals),
+ instmap_delta_init_reachable(InstMapDelta0),
+ instmap_delta_insert(InstMapDelta0, ArgTypeClassInfoVar,
+ ground(shared, no), InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, GoalInfo),
+ CallGoal = call(PredId, ProcId, Args, not_builtin,
+ MaybeContext, SymName) - GoalInfo,
+ get_arg_typeclass_infos(TypeClassInfoVar, PredId, ProcId, SymName,
+ InstanceConstraints, ConstraintNum + 1, Goals,
+ Vars, ProcInfo2, ProcInfo).
+
+:- pred construct_specialized_higher_order_call(module_info::in,
+ pred_id::in, proc_id::in, list(prog_var)::in, hlds_goal_info::in,
+ hlds_goal::out, higher_order_info::in, higher_order_info::out) is det.
+
+construct_specialized_higher_order_call(ModuleInfo, PredId, ProcId,
+ AllArgs, GoalInfo, Goal - GoalInfo, Info0, Info) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_module(PredInfo, ModuleName),
+ pred_info_name(PredInfo, PredName),
+ SymName = qualified(ModuleName, PredName),
+ code_util__builtin_state(ModuleInfo, PredId, ProcId, Builtin),
+
+ MaybeContext = no,
+ Goal1 = call(PredId, ProcId, AllArgs, Builtin, MaybeContext, SymName),
+ higher_order_info_update_changed_status(changed, Info0, Info1),
+ maybe_specialize_call(Goal1 - GoalInfo,
+ Goal - _, Info1, Info).
+
% Process a call to see if it could possibly be specialized.
:- pred maybe_specialize_call(hlds_goal::in, hlds_goal::out,
higher_order_info::in, higher_order_info::out) is det.
@@ -672,30 +875,76 @@
interpret_typeclass_info_manipulator(Manipulator, Args0,
Goal0, Goal, Info0, Info)
;
- ( pred_info_is_imported(CalleePredInfo)
- ; pred_info_get_goal_type(CalleePredInfo, pragmas)
+ (
+ pred_info_is_imported(CalleePredInfo),
+ module_info_type_spec_info(Module,
+ type_spec_info(TypeSpecProcs, _, _, _)),
+ \+ set__member(proc(CalledPred, CalledProc),
+ TypeSpecProcs)
+ ;
+ pred_info_is_pseudo_imported(CalleePredInfo),
+ hlds_pred__in_in_unification_proc_id(CalledProc)
+ ;
+ pred_info_get_goal_type(CalleePredInfo, pragmas)
)
->
Info = Info0,
Goal = Goal0
;
pred_info_arg_types(CalleePredInfo, CalleeArgTypes),
+ pred_info_import_status(CalleePredInfo, CalleeStatus),
proc_info_vartypes(ProcInfo, VarTypes),
- find_higher_order_args(Module, Args0, CalleeArgTypes,
- VarTypes, PredVars, 1, [], HigherOrderArgs0,
- Args0, Args1),
- ( HigherOrderArgs0 = [] ->
- Info = Info0,
- Goal = Goal0
+ find_higher_order_args(Module, CalleeStatus, Args0,
+ CalleeArgTypes, VarTypes, PredVars, 1, [],
+ HigherOrderArgs0),
+
+ PredProcId = proc(CallerPredId, _),
+ module_info_type_spec_info(Module,
+ type_spec_info(_, ForceVersions, _, _)),
+ ( set__member(CallerPredId, ForceVersions) ->
+ IsUserSpecProc = yes
;
+ IsUserSpecProc = no
+ ),
+
+ (
+ (
+ HigherOrderArgs0 = [_ | _]
+ ;
+ % We should create these
+ % even if there is no specialization
+ % to avoid link errors.
+ IsUserSpecProc = yes
+ ;
+ Params = ho_params(_, _, UserTypeSpec, _, _),
+ UserTypeSpec = yes,
+ map__apply_to_list(Args0, VarTypes, ArgTypes),
+
+ % Check whether any typeclass constraints
+ % now match an instance.
+ pred_info_get_class_context(CalleePredInfo,
+ CalleeClassContext),
+ CalleeClassContext =
+ constraints(CalleeUnivConstraints0, _),
+ pred_info_typevarset(CalleePredInfo,
+ CalleeTVarSet),
+ pred_info_get_exist_quant_tvars(CalleePredInfo,
+ CalleeExistQTVars),
+ pred_info_typevarset(PredInfo, TVarSet),
+ type_subst_makes_instance_known(
+ Module, CalleeUnivConstraints0,
+ TVarSet, ArgTypes, CalleeTVarSet,
+ CalleeExistQTVars, CalleeArgTypes)
+ )
+ ->
list__reverse(HigherOrderArgs0, HigherOrderArgs),
find_matching_version(Info0, CalledPred, CalledProc,
- Args0, Args1, HigherOrderArgs, FindResult),
+ Args0, HigherOrderArgs, IsUserSpecProc,
+ FindResult),
(
- FindResult = match(Match, ExtraTypeInfos),
+ FindResult = match(match(Match, _, Args)),
Match = new_pred(NewPredProcId, _, _,
- NewName, _HOArgs, _, _, _, _, _),
- list__append(ExtraTypeInfos, Args1, Args),
+ NewName, _HOArgs, _, _, _, _, _, _),
NewPredProcId = proc(NewCalledPred,
NewCalledProc),
Goal = call(NewCalledPred, NewCalledProc,
@@ -707,34 +956,38 @@
% There is a known higher order variable in
% the call, so we put in a request for a
% specialized version of the pred.
- Goal = Goal0,
FindResult = request(Request),
+ Goal = Goal0,
set__insert(Requests0, Request, Requests),
update_changed_status(Changed0,
request, Changed)
+ ;
+ FindResult = no_request,
+ Goal = Goal0,
+ Requests = Requests0,
+ Changed = Changed0
),
Info = info(PredVars, Requests, NewPreds, PredProcId,
PredInfo, ProcInfo, Module, Params, Changed)
- )
+ ;
+ Info = Info0,
+ Goal = Goal0
+ )
).
% Returns a list of the higher-order arguments in a call that have
- % a known value. Also update the argument list to now include
- % curried arguments that need to be explicitly passed.
- % The order of the argument list must match that generated
- % by construct_higher_order_terms.
-:- pred find_higher_order_args(module_info::in, list(prog_var)::in,
- list(type)::in, map(prog_var, type)::in, pred_vars::in, int::in,
- list(higher_order_arg)::in, list(higher_order_arg)::out,
- list(prog_var)::in, list(prog_var)::out) is det.
+ % a known value.
+:- pred find_higher_order_args(module_info::in, import_status::in,
+ list(prog_var)::in, list(type)::in, map(prog_var, type)::in,
+ pred_vars::in, int::in, list(higher_order_arg)::in,
+ list(higher_order_arg)::out) is det.
-find_higher_order_args(_, [], _, _, _, _,
- HOArgs, HOArgs, NewArgs, NewArgs).
-find_higher_order_args(_, [_|_], [], _, _, _, _, _, _, _) :-
+find_higher_order_args(_, _, [], _, _, _, _, HOArgs, HOArgs).
+find_higher_order_args(_, _, [_|_], [], _, _, _, _, _) :-
error("find_higher_order_args: length mismatch").
-find_higher_order_args(ModuleInfo, [Arg | Args],
- [CalleeArgType | CalleeArgTypes], VarTypes, PredVars, ArgNo,
- HOArgs0, HOArgs, NewArgs0, NewArgs) :-
+find_higher_order_args(ModuleInfo, CalleeStatus, [Arg | Args],
+ [CalleeArgType | CalleeArgTypes], VarTypes,
+ PredVars, ArgNo, HOArgs0, HOArgs) :-
NextArg is ArgNo + 1,
(
% We don't specialize arguments whose declared type is
@@ -750,6 +1003,10 @@
ConsId \= int_const(_),
( ConsId = pred_const(_, _) ->
+ % If we don't have clauses for the callee, we can't
+ % specialize any higher-order arguments. We may be
+ % able to do user guided type specialization.
+ CalleeStatus \= imported,
type_is_higher_order(CalleeArgType, _, _)
;
true
@@ -764,53 +1021,164 @@
;
CurriedCalleeArgTypes = CurriedArgTypes
),
- find_higher_order_args(ModuleInfo, CurriedArgs,
+ find_higher_order_args(ModuleInfo, CalleeStatus, CurriedArgs,
CurriedCalleeArgTypes, VarTypes,
- PredVars, 1, [], HOCurriedArgs0,
- CurriedArgs, NewExtraArgs),
+ PredVars, 1, [], HOCurriedArgs0),
list__reverse(HOCurriedArgs0, HOCurriedArgs),
list__length(CurriedArgs, NumArgs),
HOArg = higher_order_arg(ConsId, ArgNo, NumArgs,
CurriedArgs, CurriedArgTypes, HOCurriedArgs),
- HOArgs1 = [HOArg | HOArgs0],
- list__append(NewArgs0, NewExtraArgs, NewArgs1)
+ HOArgs1 = [HOArg | HOArgs0]
;
- HOArgs1 = HOArgs0,
- NewArgs1 = NewArgs0
+ HOArgs1 = HOArgs0
),
- find_higher_order_args(ModuleInfo, Args, CalleeArgTypes,
- VarTypes, PredVars, NextArg, HOArgs1, HOArgs,
- NewArgs1, NewArgs).
+ find_higher_order_args(ModuleInfo, CalleeStatus, Args, CalleeArgTypes,
+ VarTypes, PredVars, NextArg, HOArgs1, HOArgs).
+
+ % Succeeds if the type substitution for a call makes any of
+ % the class constraints match an instance which was not matched
+ % before.
+:- pred type_subst_makes_instance_known(module_info::in,
+ list(class_constraint)::in, tvarset::in, list(type)::in,
+ tvarset::in, existq_tvars::in, list(type)::in) is semidet.
+
+type_subst_makes_instance_known(ModuleInfo, CalleeUnivConstraints0, TVarSet0,
+ ArgTypes, CalleeTVarSet, CalleeExistQVars, CalleeArgTypes0) :-
+ CalleeUnivConstraints0 \= [],
+ varset__merge_subst(TVarSet0, CalleeTVarSet,
+ TVarSet, TypeRenaming),
+ term__apply_substitution_to_list(CalleeArgTypes0, TypeRenaming,
+ CalleeArgTypes1),
+
+ % Substitute the types in the callee's class constraints.
+ % Typechecking has already succeeded, so none of the head type
+ % variables will be bound by the substitution.
+ HeadTypeParams = [],
+ inlining__get_type_substitution(CalleeArgTypes1, ArgTypes,
+ HeadTypeParams, CalleeExistQVars, TypeSubn),
+ apply_subst_to_constraint_list(TypeRenaming,
+ CalleeUnivConstraints0, CalleeUnivConstraints1),
+ apply_rec_subst_to_constraint_list(TypeSubn,
+ CalleeUnivConstraints1, CalleeUnivConstraints),
+ assoc_list__from_corresponding_lists(CalleeUnivConstraints0,
+ CalleeUnivConstraints, CalleeUnivConstraintAL),
+
+ % Go through each constraint in turn, checking whether any instances
+ % match which didn't before the substitution was applied.
+ list__member(CalleeUnivConstraint0 - CalleeUnivConstraint,
+ CalleeUnivConstraintAL),
+ CalleeUnivConstraint0 = constraint(ClassName, ConstraintArgs0),
+ list__length(ConstraintArgs0, ClassArity),
+ CalleeUnivConstraint = constraint(_, ConstraintArgs),
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__search(InstanceTable, class_id(ClassName, ClassArity), Instances),
+ list__member(Instance, Instances),
+ instance_matches(ConstraintArgs, Instance, _, TVarSet, _),
+ \+ instance_matches(ConstraintArgs0, Instance, _, TVarSet, _).
:- type find_result
- ---> match(
- new_pred, % Specialised version to use.
- list(prog_var) % Ordered list of extra type-info
- % variables to add to the front of
- % the argument list, empty if
- % --typeinfo-liveness is not set.
- )
- ; request(request)
+ ---> match(match)
+ ; request(request)
+ ; no_request
.
+:- type match
+ ---> match(
+ new_pred,
+ maybe(int), % was the match partial, if so,
+ % how many higher_order arguments
+ % matched.
+ list(prog_var) % the arguments to the specialised call
+ ).
+
:- pred find_matching_version(higher_order_info::in,
- pred_id::in, proc_id::in, list(prog_var)::in, list(prog_var)::in,
- list(higher_order_arg)::in, find_result::out) is det.
+ pred_id::in, proc_id::in, list(prog_var)::in,
+ list(higher_order_arg)::in, bool::in, find_result::out) is det.
% Args0 is the original list of arguments.
% Args1 is the original list of arguments with the curried arguments
% of known higher-order arguments added.
-find_matching_version(Info, CalledPred, CalledProc, Args0, Args1,
- HigherOrderArgs, Result) :-
+find_matching_version(Info, CalledPred, CalledProc, Args0,
+ HigherOrderArgs, IsUserSpecProc, Result) :-
Info = info(_, _, NewPreds, Caller,
- PredInfo, ProcInfo, ModuleInfo, _, _),
+ PredInfo, ProcInfo, ModuleInfo, Params, _),
+
+ compute_extra_typeinfos(Info, Args0, ExtraTypeInfos,
+ ExtraTypeInfoTypes),
+
proc_info_vartypes(ProcInfo, VarTypes),
- pred_info_arg_types(PredInfo, _, ExistQVars, _),
+ map__apply_to_list(Args0, VarTypes, CallArgTypes),
pred_info_typevarset(PredInfo, TVarSet),
- module_info_globals(ModuleInfo, Globals),
- globals__lookup_bool_option(Globals,
- typeinfo_liveness, TypeInfoLiveness),
+ Request = request(Caller, proc(CalledPred, CalledProc), Args0,
+ ExtraTypeInfos, HigherOrderArgs, CallArgTypes,
+ ExtraTypeInfoTypes, TVarSet, IsUserSpecProc),
+
+ % Check to see if any of the specialized
+ % versions of the called pred apply here.
+ (
+ NewPreds = new_preds(NewPredMap, _),
+ map__search(NewPredMap, proc(CalledPred, CalledProc),
+ Versions0),
+ set__to_sorted_list(Versions0, Versions),
+ search_for_version(Info, Params, ModuleInfo, Request, Args0,
+ Versions, no, Match)
+ ->
+ Result = match(Match)
+ ;
+ Params = ho_params(HigherOrder, TypeSpec, UserTypeSpec, _, _),
+ (
+ UserTypeSpec = yes,
+ IsUserSpecProc = yes
+ ;
+ module_info_pred_info(ModuleInfo,
+ CalledPred, CalledPredInfo),
+ \+ pred_info_is_imported(CalledPredInfo),
+ (
+ % This handles the introduced predicates
+ % which call class methods. Without this,
+ % user-specified specialized versions of
+ % class methods won't be called.
+ UserTypeSpec = yes,
+ (
+ pred_info_get_markers(CalledPredInfo,
+ Markers),
+ check_marker(Markers, class_method)
+ ;
+ pred_info_name(CalledPredInfo,
+ CalledPredName),
+ string__prefix(CalledPredName,
+ "Introduced_")
+ )
+ ;
+ HigherOrder = yes,
+ list__member(HOArg, HigherOrderArgs),
+ HOArg = higher_order_arg(pred_const(_, _),
+ _, _, _, _, _)
+ ;
+ TypeSpec = yes
+ )
+ )
+ ->
+ Result = request(Request)
+ ;
+ Result = no_request
+ ).
+
+ % If `--typeinfo-liveness' is set, specializing type `T' to `list(U)'
+ % requires passing in the type-info for `U'. This predicate
+ % works out which extra variables to pass in given the argument
+ % list for the call.
+:- pred compute_extra_typeinfos(higher_order_info::in, list(prog_var)::in,
+ list(prog_var)::out, list(type)::out) is det.
+
+compute_extra_typeinfos(Info, Args1, ExtraTypeInfos, ExtraTypeInfoTypes) :-
+ Info = info(_, _, _, _, PredInfo, ProcInfo, _, Params, _),
+
+ proc_info_vartypes(ProcInfo, VarTypes),
+ pred_info_arg_types(PredInfo, _, ExistQVars, _),
+
+ Params = ho_params(_, _, _, _, TypeInfoLiveness),
( TypeInfoLiveness = yes ->
set__list_to_set(Args1, NonLocals0),
proc_info_typeinfo_varmap(ProcInfo, TVarMap),
@@ -824,90 +1192,134 @@
;
ExtraTypeInfos = [],
ExtraTypeInfoTypes = []
- ),
-
- map__apply_to_list(Args0, VarTypes, CallArgTypes),
- Request = request(Caller, proc(CalledPred, CalledProc), Args0,
- ExtraTypeInfos, HigherOrderArgs, CallArgTypes,
- ExtraTypeInfoTypes, TVarSet),
-
- % Check to see if any of the specialized
- % versions of the called pred apply here.
- (
- NewPreds = new_preds(NewPredMap, _),
- map__search(NewPredMap, proc(CalledPred, CalledProc),
- NewPredSet),
- set__to_sorted_list(NewPredSet, NewPredList),
- search_for_version(TypeInfoLiveness, ModuleInfo, Request,
- ExtraTypeInfos, NewPredList,
- Match, OrderedExtraTypeInfos)
- ->
- Result = match(Match, OrderedExtraTypeInfos)
- ;
- Result = request(Request)
).
-:- pred search_for_version(bool::in, module_info::in, request::in,
- list(prog_var)::in, list(new_pred)::in, new_pred::out,
- list(prog_var)::out) is semidet.
-
-search_for_version(TypeInfoLiveness, ModuleInfo, Request, ExtraTypeInfos,
- [Version | Versions], Match, OrderedExtraTypeInfos) :-
+:- pred search_for_version(higher_order_info::in, ho_params::in,
+ module_info::in, request::in, list(prog_var)::in,
+ list(new_pred)::in, maybe(match)::in, match::out) is semidet.
+
+search_for_version(_Info, _Params, _ModuleInfo, _Request, _Args0,
+ [], yes(Match), Match).
+search_for_version(Info, Params, ModuleInfo, Request, Args0,
+ [Version | Versions], Match0, Match) :-
(
- version_matches(TypeInfoLiveness, ModuleInfo, Request,
- Version, yes(ExtraTypeInfos), OrderedExtraTypeInfos0)
+ version_matches(Params, ModuleInfo, Request, yes(Args0 - Info),
+ Version, Match1)
->
- Match = Version,
- OrderedExtraTypeInfos = OrderedExtraTypeInfos0
+ (
+ Match1 = match(_, no, _)
+ ->
+ Match = Match1
+ ;
+ (
+ Match0 = no
+ ->
+ Match2 = yes(Match1)
+ ;
+ % pick the best match
+ Match0 = yes(match(_, yes(NumMatches0), _)),
+ Match1 = match(_, yes(NumMatches1), _)
+ ->
+ ( NumMatches0 > NumMatches1 ->
+ Match2 = Match0
+ ;
+ Match2 = yes(Match1)
+ )
+ ;
+ error("higher_order: search_for_version")
+ ),
+ search_for_version(Info, Params, ModuleInfo, Request,
+ Args0, Versions, Match2, Match)
+ )
;
- search_for_version(TypeInfoLiveness, ModuleInfo, Request,
- ExtraTypeInfos, Versions, Match, OrderedExtraTypeInfos)
+ search_for_version(Info, Params, ModuleInfo, Request,
+ Args0, Versions, Match0, Match)
).
% Check whether the request has already been implemented by
% the new_pred, maybe ordering the list of extra type_infos
% in the caller predicate to match up with those in the caller.
-:- pred version_matches(bool::in, module_info::in, request::in,
- new_pred::in, maybe(list(prog_var))::in, list(prog_var)::out)
- is semidet.
+:- pred version_matches(ho_params::in, module_info::in, request::in,
+ maybe(pair(list(prog_var), higher_order_info))::in,
+ new_pred::in, match::out) is semidet.
-version_matches(TypeInfoLiveness, _ModuleInfo, Request, Version,
- MaybeExtraTypeInfos, OrderedExtraTypeInfos) :-
+version_matches(Params, ModuleInfo, Request, MaybeArgs0, Version,
+ match(Version, PartialMatch, Args)) :-
- Request = request(_, _, _, _, RequestHigherOrderArgs, CallArgTypes,
- ExtraTypeInfoTypes, RequestTVarSet),
+ Request = request(_, Callee, _, _, RequestHigherOrderArgs,
+ CallArgTypes, _, RequestTVarSet, _),
Version = new_pred(_, _, _, _, VersionHigherOrderArgs, _, _,
- VersionArgTypes0, VersionExtraTypeInfoTypes0, VersionTVarSet),
+ VersionArgTypes0, VersionExtraTypeInfoTypes,
+ VersionTVarSet, VersionIsUserSpec),
higher_order_args_match(RequestHigherOrderArgs,
- VersionHigherOrderArgs),
+ VersionHigherOrderArgs, HigherOrderArgs, MatchIsPartial),
+
+ ( MatchIsPartial = yes ->
+ list__length(HigherOrderArgs, NumHOArgs),
+ PartialMatch = yes(NumHOArgs)
+ ;
+ PartialMatch = no
+ ),
+
+ Params = ho_params(_, TypeSpec, _, _, TypeInfoLiveness),
+
+ Callee = proc(CalleePredId, _),
+ module_info_pred_info(ModuleInfo, CalleePredId, CalleePredInfo),
+ (
+ % Don't accept partial matches unless the predicate is
+ % imported or we are only doing user-guided type
+ % specialization.
+ MatchIsPartial = no
+ ;
+ TypeSpec = no
+ ;
+ pred_info_is_imported(CalleePredInfo)
+ ),
% Rename apart type variables.
varset__merge_subst(RequestTVarSet, VersionTVarSet, _, TVarSubn),
term__apply_substitution_to_list(VersionArgTypes0, TVarSubn,
VersionArgTypes),
- term__apply_substitution_to_list(VersionExtraTypeInfoTypes0,
- TVarSubn, VersionExtraTypeInfoTypes),
type_list_subsumes(VersionArgTypes, CallArgTypes, Subn),
- ( TypeInfoLiveness = yes ->
- % If typeinfo_liveness is set, the subsumption
- % must go in both directions, since otherwise
- % the set of type_infos which need to be passed
- % might not be the same.
+
+ % If typeinfo_liveness is set, the subsumption must go both ways,
+ % since otherwise a different set of typeinfos may need to be passed.
+ % For user-specified type specializations, it is guaranteed that
+ % no extra typeinfos are required because the substitution supplied
+ % by the user is not allowed to partially instantiate type variables.
+ ( TypeInfoLiveness = yes, VersionIsUserSpec = no ->
type_list_subsumes(CallArgTypes, VersionArgTypes, _)
;
true
),
- ( TypeInfoLiveness = yes, MaybeExtraTypeInfos = yes(ExtraTypeInfos) ->
- term__apply_rec_substitution_to_list(
- VersionExtraTypeInfoTypes,
- Subn, RenamedVersionTypeInfos),
- assoc_list__from_corresponding_lists(ExtraTypeInfos,
- ExtraTypeInfoTypes, ExtraTypeInfoAL),
- order_typeinfos(Subn, ExtraTypeInfoAL, RenamedVersionTypeInfos,
- [], OrderedExtraTypeInfos)
+
+ ( MaybeArgs0 = yes(Args0 - Info) ->
+ get_extra_arguments(HigherOrderArgs, Args0, Args1),
+
+ % For user-specified type specializations, it is guaranteed
+ % that no extra typeinfos are required because the
+ % substitution supplied by the user is not allowed to
+ % partially instantiate type variables.
+ ( VersionIsUserSpec = yes ->
+ Args = Args1
+ ;
+ compute_extra_typeinfos(Info, Args1, ExtraTypeInfos,
+ ExtraTypeInfoTypes),
+ term__apply_rec_substitution_to_list(
+ VersionExtraTypeInfoTypes,
+ Subn, RenamedVersionTypeInfos),
+ assoc_list__from_corresponding_lists(ExtraTypeInfos,
+ ExtraTypeInfoTypes, ExtraTypeInfoAL),
+ order_typeinfos(Subn, ExtraTypeInfoAL,
+ RenamedVersionTypeInfos,
+ [], OrderedExtraTypeInfos),
+ list__append(OrderedExtraTypeInfos, Args1, Args)
+ )
;
- OrderedExtraTypeInfos = []
+ % This happens when called from create_new_preds -- it doesn't
+ % care about the arguments.
+ Args = []
).
% Put the extra typeinfos for --typeinfo-liveness in the correct
@@ -944,16 +1356,56 @@
).
:- pred higher_order_args_match(list(higher_order_arg)::in,
- list(higher_order_arg)::in) is semidet.
+ list(higher_order_arg)::in, list(higher_order_arg)::out,
+ bool::out) is semidet.
-higher_order_args_match([], []).
-higher_order_args_match([Arg1 | Args1], [Arg2 | Args2]) :-
- Arg1 = higher_order_arg(ConsId, ArgNo, NumArgs,
- _, _, HOCurriedArgs1),
- Arg2 = higher_order_arg(ConsId, ArgNo, NumArgs,
+higher_order_args_match([], [], [], no).
+higher_order_args_match([_ | _], [], [], yes).
+higher_order_args_match([RequestArg | Args1], [VersionArg | Args2],
+ Args, PartialMatch) :-
+ RequestArg = higher_order_arg(ConsId1, ArgNo1, _, _, _, _),
+ VersionArg = higher_order_arg(ConsId2, ArgNo2, _, _, _, _),
+
+ ( ArgNo1 = ArgNo2 ->
+ ConsId1 = ConsId2,
+ RequestArg = higher_order_arg(_, _, NumArgs,
+ CurriedArgs, CurriedArgTypes, HOCurriedArgs1),
+ VersionArg = higher_order_arg(_, _, NumArgs,
_, _, HOCurriedArgs2),
- higher_order_args_match(HOCurriedArgs1, HOCurriedArgs2),
- higher_order_args_match(Args1, Args2).
+ higher_order_args_match(HOCurriedArgs1, HOCurriedArgs2,
+ NewHOCurriedArgs, PartialMatch),
+ higher_order_args_match(Args1, Args2, Args3, _),
+ NewRequestArg = higher_order_arg(ConsId1, ArgNo1, NumArgs,
+ CurriedArgs, CurriedArgTypes, NewHOCurriedArgs),
+ Args = [NewRequestArg | Args3]
+ ;
+ % type-info arguments present in the request may be missing
+ % from the version if we are doing user-guided type
+ % specialization.
+ % All of the arguments in the version must be
+ % present in the request for a match.
+ ArgNo1 < ArgNo2,
+
+ % All the higher-order arguments must be present in the
+ % version otherwise we should create a new one.
+ ConsId1 \= pred_const(_, _),
+ PartialMatch = yes,
+ higher_order_args_match(Args1, [VersionArg | Args2], Args, _)
+ ).
+
+ % Add the curried arguments of the higher-order terms to the
+ % argument list. The order here must match that generated by
+ % construct_higher_order_terms.
+:- pred get_extra_arguments(list(higher_order_arg)::in,
+ list(prog_var)::in, list(prog_var)::out) is det.
+
+get_extra_arguments([], Args, Args).
+get_extra_arguments([HOArg | HOArgs], Args0, Args) :-
+ HOArg = higher_order_arg(_, _, _,
+ CurriedArgs0, _, HOCurriedArgs),
+ get_extra_arguments(HOCurriedArgs, CurriedArgs0, CurriedArgs),
+ list__append(Args0, CurriedArgs, Args1),
+ get_extra_arguments(HOArgs, Args1, Args).
% if the right argument of an assignment is a higher order
% term with a known value, we need to add an entry for
@@ -992,16 +1444,17 @@
%-------------------------------------------------------------------------------
- % Interpret a call to `type_info_from_typeclass_info' or
- % `superclass_from_typeclass_info'. Currently they both have
- % the same definition. This should be kept in sync with
- % compiler/polymorphism.m, library/private_builtin.m and
- % runtime/mercury_type_info.h.
+ % Interpret a call to `type_info_from_typeclass_info',
+ % `superclass_from_typeclass_info' or
+ % `instance_constraint_from_typeclass_info'.
+ % This should be kept in sync with compiler/polymorphism.m,
+ % library/private_builtin.m and runtime/mercury_type_info.h.
:- pred interpret_typeclass_info_manipulator(typeclass_info_manipulator::in,
list(prog_var)::in, hlds_goal_expr::in, hlds_goal_expr::out,
higher_order_info::in, higher_order_info::out) is det.
-interpret_typeclass_info_manipulator(_, Args, Goal0, Goal, Info0, Info) :-
+interpret_typeclass_info_manipulator(Manipulator, Args,
+ Goal0, Goal, Info0, Info) :-
Info0 = info(PredVars0, _, _, _, _, _, ModuleInfo, _, _),
(
Args = [TypeClassInfoVar, IndexVar, TypeInfoVar],
@@ -1009,7 +1462,7 @@
constant(_TypeClassInfoConsId, TypeClassInfoArgs)),
map__search(PredVars0, IndexVar,
- constant(int_const(Index), [])),
+ constant(int_const(Index0), [])),
% Extract the number of class constraints on the instance
% from the base_typeclass_info.
@@ -1023,9 +1476,21 @@
map__lookup(Instances, ClassId, InstanceDefns),
list__index1_det(InstanceDefns, InstanceNum, InstanceDefn),
InstanceDefn = hlds_instance_defn(_, _, Constraints, _,_,_,_,_),
- list__length(Constraints, NumConstraints),
- TypeInfoIndex is Index + NumConstraints,
- list__index1_det(OtherVars, TypeInfoIndex, TypeInfoArg),
+ (
+ Manipulator = type_info_from_typeclass_info,
+ list__length(Constraints, NumConstraints),
+ Index = Index0 + NumConstraints
+ ;
+ Manipulator = superclass_from_typeclass_info,
+ list__length(Constraints, NumConstraints),
+ % polymorphism.m adds the number of
+ % type_infos to the index.
+ Index = Index0 + NumConstraints
+ ;
+ Manipulator = instance_constraint_from_typeclass_info,
+ Index = Index0
+ ),
+ list__index1_det(OtherVars, Index, TypeInfoArg),
maybe_add_alias(TypeInfoVar, TypeInfoArg, Info0, Info),
Uni = assign(TypeInfoVar, TypeInfoArg),
in_mode(In),
@@ -1096,70 +1561,100 @@
% involving recursively building up lambda expressions
% this can create ridiculous numbers of versions.
:- pred filter_requests(ho_params::in, module_info::in,
- set(request)::in, goal_sizes::in, list(request)::out) is det.
+ set(request)::in, goal_sizes::in, list(request)::out,
+ io__state::di, io__state::uo) is det.
-filter_requests(Params, ModuleInfo, Requests0, GoalSizes, Requests) :-
- Params = ho_params(_, _, MaxSize),
- set__to_sorted_list(Requests0, Requests1),
- list__filter(lambda([X::in] is semidet, (
- X = request(_, CalledPredProcId, _, _, _, _, _, _),
- CalledPredProcId = proc(CalledPredId,
- CalledProcId),
- module_info_pred_info(ModuleInfo,
- CalledPredId, PredInfo),
- \+ pred_info_is_imported(PredInfo),
- \+ (
- pred_info_is_pseudo_imported(PredInfo),
- hlds_pred__in_in_unification_proc_id(
- CalledProcId)
- ),
+filter_requests(Params, ModuleInfo, Requests0, GoalSizes, Requests) -->
+ { set__to_sorted_list(Requests0, Requests1) },
+ filter_requests_2(Params, ModuleInfo, Requests1, GoalSizes,
+ [], Requests).
+
+:- pred filter_requests_2(ho_params::in, module_info::in, list(request)::in,
+ goal_sizes::in, list(request)::in, list(request)::out,
+ io__state::di, io__state::uo) is det.
+
+filter_requests_2(_, _, [], _, Requests, Requests) --> [].
+filter_requests_2(Params, ModuleInfo, [Request | Requests0],
+ GoalSizes, FilteredRequests0, FilteredRequests) -->
+ { Params = ho_params(_, _, _, MaxSize, _) },
+ { Request = request(_, CalledPredProcId, _, _, HOArgs,
+ _, _, _, IsUserTypeSpec) },
+ { CalledPredProcId = proc(CalledPredId, _) },
+ { module_info_pred_info(ModuleInfo, CalledPredId, PredInfo) },
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose),
+ { pred_info_module(PredInfo, PredModule) },
+ { pred_info_name(PredInfo, PredName) },
+ { pred_info_arity(PredInfo, Arity) },
+ { pred_info_arg_types(PredInfo, Types) },
+ { list__length(Types, ActualArity) },
+ maybe_write_request(VeryVerbose, ModuleInfo, "% Request for",
+ qualified(PredModule, PredName), Arity, ActualArity,
+ no, HOArgs),
+ (
+ {
+ % Ignore the size limit for user
+ % specified specializations.
+ IsUserTypeSpec = yes
+ ;
map__search(GoalSizes, CalledPredId, GoalSize),
- GoalSize =< MaxSize,
- pred_info_name(PredInfo, PredName),
- \+ (
+ GoalSize =< MaxSize
+ }
+ ->
+ (
+ \+ {
% There are probably cleaner ways to check
% if this is a specialised version.
- string__sub_string_search(PredName,
+ string__sub_string_search(PredName,
"__ho", Index),
NumIndex is Index + 4,
string__index(PredName, NumIndex, Digit),
char__is_digit(Digit)
- )
- )),
- Requests1, Requests).
+ }
+ ->
+ { FilteredRequests1 = [Request | FilteredRequests0] }
+ ;
+ { FilteredRequests1 = FilteredRequests0 },
+ maybe_write_string(VeryVerbose,
+ "% Not specializing (recursive specialization):\n")
+ )
+ ;
+ { FilteredRequests1 = FilteredRequests0 },
+ maybe_write_string(VeryVerbose,
+ "% Not specializing (goal too large):\n")
+ ),
+ filter_requests_2(Params, ModuleInfo, Requests0, GoalSizes,
+ FilteredRequests1, FilteredRequests).
-:- pred create_new_preds(list(request)::in, new_preds::in, new_preds::out,
- list(new_pred)::in, list(new_pred)::out,
+:- pred create_new_preds(ho_params::in, list(request)::in, new_preds::in,
+ new_preds::out, list(new_pred)::in, list(new_pred)::out,
set(pred_proc_id)::in, set(pred_proc_id)::out, int::in,
int::out, module_info::in, module_info::out,
io__state::di, io__state::uo) is det.
-create_new_preds([], NewPreds, NewPreds, NewPredList, NewPredList,
+create_new_preds(_, [], NewPreds, NewPreds, NewPredList, NewPredList,
ToFix, ToFix, NextId, NextId, Mod, Mod, IO, IO).
-create_new_preds([Request | Requests], NewPreds0, NewPreds,
+create_new_preds(Params, [Request | Requests], NewPreds0, NewPreds,
NewPredList0, NewPredList, PredsToFix0, PredsToFix,
NextHOid0, NextHOid, Module0, Module, IO0, IO) :-
Request = request(CallingPredProcId, CalledPredProcId, _HOArgs,
- _CallArgs, _, _CallerArgTypes, _ExtraTypeInfoTypes, _),
+ _CallArgs, _, _CallerArgTypes, _ExtraTypeInfoTypes, _, _),
set__insert(PredsToFix0, CallingPredProcId, PredsToFix1),
(
NewPreds0 = new_preds(NewPredMap0, _),
map__search(NewPredMap0, CalledPredProcId, SpecVersions0)
->
- globals__io_lookup_bool_option(typeinfo_liveness,
- TypeInfoLiveness, IO0, IO1),
(
% check that we aren't redoing the same pred
% SpecVersions are pred_proc_ids of the specialized
% versions of the current pred.
\+ (
set__member(Version, SpecVersions0),
- version_matches(TypeInfoLiveness, Module0,
- Request, Version, no, _)
+ version_matches(Params, Module0,
+ Request, no, Version, _)
)
->
create_new_pred(Request, NewPred, NextHOid0,
- NextHOid1, Module0, Module1, IO1, IO2),
+ NextHOid1, Module0, Module1, IO0, IO2),
add_new_pred(CalledPredProcId, NewPred,
NewPreds0, NewPreds1),
NewPredList1 = [NewPred | NewPredList0]
@@ -1167,7 +1662,7 @@
Module1 = Module0,
NewPredList1 = NewPredList0,
NewPreds1 = NewPreds0,
- IO2 = IO1,
+ IO2 = IO0,
NextHOid1 = NextHOid0
)
;
@@ -1176,7 +1671,7 @@
add_new_pred(CalledPredProcId, NewPred, NewPreds0, NewPreds1),
NewPredList1 = [NewPred | NewPredList0]
),
- create_new_preds(Requests, NewPreds1, NewPreds, NewPredList1,
+ create_new_preds(Params, Requests, NewPreds1, NewPreds, NewPredList1,
NewPredList, PredsToFix1, PredsToFix, NextHOid1, NextHOid,
Module1, Module, IO2, IO).
@@ -1199,7 +1694,8 @@
create_new_pred(Request, NewPred, NextHOid0, NextHOid,
ModuleInfo0, ModuleInfo, IOState0, IOState) :-
Request = request(Caller, CalledPredProc, CallArgs, ExtraTypeInfoArgs,
- HOArgs, ArgTypes, ExtraTypeInfoTypes, CallerTVarSet),
+ HOArgs, ArgTypes, ExtraTypeInfoTypes,
+ CallerTVarSet, IsUserTypeSpec),
CalledPredProc = proc(CalledPred, _),
module_info_get_predicate_table(ModuleInfo0, PredTable0),
predicate_table_get_preds(PredTable0, Preds0),
@@ -1211,32 +1707,42 @@
globals__io_lookup_bool_option(very_verbose, VeryVerbose,
IOState0, IOState1),
pred_info_arg_types(PredInfo0, ArgTVarSet, ExistQVars, Types),
- string__int_to_string(Arity, ArStr),
- (
- VeryVerbose = yes
- ->
- prog_out__sym_name_to_string(PredModule, PredModuleString),
- io__write_strings(["% Specializing calls to `",
- PredModuleString, ":", Name0, "'/", ArStr,
- " with higher-order arguments:\n"],
- IOState1, IOState2),
- list__length(Types, ActualArity),
- NumToDrop is ActualArity - Arity,
- output_higher_order_args(ModuleInfo0, NumToDrop,
- HOArgs, IOState2, IOState)
- ;
- IOState = IOState1
- ),
- string__int_to_string(NextHOid0, IdStr),
- NextHOid is NextHOid0 + 1,
- string__append_list([Name0, "__ho", IdStr], PredName),
+
+ ( IsUserTypeSpec = yes ->
+ % If this is a user-guided type specialisation, the
+ % new name comes from the name of the requesting predicate.
+ Caller = proc(CallerPredId, CallerProcId),
+ predicate_name(ModuleInfo0, CallerPredId, CallerName),
+ proc_id_to_int(CallerProcId, CallerProcInt),
+ string__int_to_string(CallerProcInt, CallerProcStr),
+ string__append_list([CallerName, "__ho", CallerProcStr],
+ PredName),
+ NextHOid = NextHOid0,
+ % For exported predicates the type specialization must
+ % be exported.
+ % For opt_imported predicates we only want to keep this
+ % version if we do some other useful specialization on it.
+ pred_info_import_status(PredInfo0, Status)
+ ;
+ string__int_to_string(NextHOid0, IdStr),
+ NextHOid is NextHOid0 + 1,
+ string__append_list([Name0, "__ho", IdStr], PredName),
+ Status = local
+ ),
+
+ SymName = qualified(PredModule, PredName),
+ unqualify_name(SymName, NewName),
+ list__length(Types, ActualArity),
+ maybe_write_request(VeryVerbose, ModuleInfo, "% Specializing",
+ qualified(PredModule, Name0), Arity, ActualArity,
+ yes(NewName), HOArgs, IOState1, IOState),
+
pred_info_typevarset(PredInfo0, TypeVarSet),
pred_info_context(PredInfo0, Context),
pred_info_get_markers(PredInfo0, MarkerList),
pred_info_get_goal_type(PredInfo0, GoalType),
pred_info_get_class_context(PredInfo0, ClassContext),
pred_info_get_aditi_owner(PredInfo0, Owner),
- Name = qualified(PredModule, PredName),
varset__init(EmptyVarSet),
map__init(EmptyVarTypes),
map__init(EmptyProofs),
@@ -1245,8 +1751,8 @@
% hlds dumps if it's filled in.
ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes,
EmptyVarTypes, [], []),
- pred_info_init(PredModule, Name, Arity, ArgTVarSet, ExistQVars,
- Types, true, Context, ClausesInfo, local, MarkerList, GoalType,
+ pred_info_init(PredModule, SymName, Arity, ArgTVarSet, ExistQVars,
+ Types, true, Context, ClausesInfo, Status, MarkerList, GoalType,
PredOrFunc, ClassContext, EmptyProofs, Owner, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVarSet, PredInfo2),
pred_info_procedures(PredInfo2, Procs0),
@@ -1254,9 +1760,30 @@
predicate_table_insert(PredTable0, PredInfo2, NewPredId, PredTable),
module_info_set_predicate_table(ModuleInfo0, PredTable, ModuleInfo),
NewPred = new_pred(proc(NewPredId, NewProcId), CalledPredProc, Caller,
- Name, HOArgs, CallArgs, ExtraTypeInfoArgs, ArgTypes,
- ExtraTypeInfoTypes, CallerTVarSet).
-
+ SymName, HOArgs, CallArgs, ExtraTypeInfoArgs, ArgTypes,
+ ExtraTypeInfoTypes, CallerTVarSet, IsUserTypeSpec).
+
+:- pred maybe_write_request(bool::in, module_info::in, string::in,
+ sym_name::in, arity::in, arity::in, maybe(string)::in,
+ list(higher_order_arg)::in, io__state::di, io__state::uo) is det.
+
+maybe_write_request(no, _, _, _, _, _, _, _) --> [].
+maybe_write_request(yes, ModuleInfo, Msg, SymName,
+ Arity, ActualArity, MaybeNewName, HOArgs) -->
+ { prog_out__sym_name_to_string(SymName, OldName) },
+ { string__int_to_string(Arity, ArStr) },
+ io__write_strings([Msg, " `", OldName, "'/", ArStr]),
+
+ ( { MaybeNewName = yes(NewName) } ->
+ io__write_string(" into "),
+ io__write_string(NewName)
+ ;
+ []
+ ),
+ io__write_string(" with higher-order arguments:\n"),
+ { NumToDrop is ActualArity - Arity },
+ output_higher_order_args(ModuleInfo, NumToDrop, HOArgs).
+
:- pred output_higher_order_args(module_info::in, int::in,
list(higher_order_arg)::in, io__state::di, io__state::uo) is det.
@@ -1275,9 +1802,20 @@
io__write_string(Name),
io__write_string("'/"),
io__write_int(Arity)
+ ; { ConsId = type_ctor_info_const(TypeModule, TypeName, TypeArity) } ->
+ io__write_string(" type_ctor_info for `"),
+ prog_out__write_sym_name(qualified(TypeModule, TypeName)),
+ io__write_string("'/"),
+ io__write_int(TypeArity)
+ ; { ConsId = base_typeclass_info_const(_, ClassId, _, _) } ->
+ io__write_string(" base_typeclass_info for `"),
+ { ClassId = class_id(ClassName, ClassArity) },
+ prog_out__write_sym_name(ClassName),
+ io__write_string("'/"),
+ io__write_int(ClassArity)
;
% XXX output the type.
- io__write_string(" type_info ")
+ io__write_string(" type_info/typeclass_info ")
),
io__write_string(" with "),
io__write_int(NumArgs),
@@ -1301,17 +1839,18 @@
set__init(Requests0),
Info0 = info(PredVars0, Requests0, NewPreds, PredProcId,
PredInfo0, ProcInfo0, ModuleInfo0, Params, unchanged),
- traverse_goal_0(Goal0, Goal1, Info0, _),
- proc_info_varset(ProcInfo0, Varset0),
- proc_info_headvars(ProcInfo0, HeadVars),
- proc_info_vartypes(ProcInfo0, VarTypes0),
+ traverse_goal_0(Goal0, Goal1, Info0, Info),
+ Info = info(_, _, _, _, PredInfo1, ProcInfo1, _, _, _),
+ proc_info_varset(ProcInfo1, Varset0),
+ proc_info_headvars(ProcInfo1, HeadVars),
+ proc_info_vartypes(ProcInfo1, VarTypes0),
implicitly_quantify_clause_body(HeadVars, Goal1, Varset0, VarTypes0,
Goal, Varset, VarTypes, _),
- proc_info_set_goal(ProcInfo0, Goal, ProcInfo1),
proc_info_set_varset(ProcInfo1, Varset, ProcInfo2),
- proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo),
+ proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo3),
+ proc_info_set_goal(ProcInfo3, Goal, ProcInfo),
map__det_update(Procs0, ProcId, ProcInfo, Procs),
- pred_info_set_procedures(PredInfo0, Procs, PredInfo),
+ pred_info_set_procedures(PredInfo1, Procs, PredInfo),
map__det_update(Preds0, PredId, PredInfo, Preds),
module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1),
fixup_preds(Params, PredProcIds, NewPreds, ModuleInfo1, ModuleInfo).
@@ -1329,7 +1868,7 @@
ModuleInfo0, ModuleInfo) :-
NewPred = new_pred(NewPredProcId, OldPredProcId, Caller, _Name,
HOArgs0, CallArgs, ExtraTypeInfoArgs, CallerArgTypes0,
- ExtraTypeInfoTypes0, _),
+ ExtraTypeInfoTypes0, _, _),
OldPredProcId = proc(OldPredId, OldProcId),
module_info_pred_proc_info(ModuleInfo0, OldPredId, OldProcId,
@@ -1477,28 +2016,28 @@
%
proc_info_goal(NewProcInfo7, Goal1),
HOInfo0 = info(PredVars, Requests0, NewPredMap1, NewPredProcId,
- NewPredInfo2, NewProcInfo6, ModuleInfo0, Params, unchanged),
+ NewPredInfo3, NewProcInfo7, ModuleInfo0, Params, unchanged),
traverse_goal_0(Goal1, Goal2, HOInfo0,
- info(_, Requests1,_,_,_,_,_,_,_)),
+ info(_, Requests1,_,_,NewPredInfo4, NewProcInfo8,_,_,_)),
goal_size(Goal2, GoalSize),
map__set(GoalSizes0, NewPredId, GoalSize, GoalSizes1),
%
% Requantify and recompute instmap deltas.
%
- proc_info_varset(NewProcInfo7, Varset7),
- proc_info_vartypes(NewProcInfo7, VarTypes7),
- implicitly_quantify_clause_body(HeadVars, Goal2, Varset7, VarTypes7,
+ proc_info_varset(NewProcInfo8, Varset8),
+ proc_info_vartypes(NewProcInfo8, VarTypes8),
+ implicitly_quantify_clause_body(HeadVars, Goal2, Varset8, VarTypes8,
Goal3, Varset, VarTypes, _),
- proc_info_get_initial_instmap(NewProcInfo3, ModuleInfo0, InstMap0),
+ proc_info_get_initial_instmap(NewProcInfo8, ModuleInfo0, InstMap0),
recompute_instmap_delta(no, Goal3, Goal4, InstMap0,
ModuleInfo0, ModuleInfo1),
- proc_info_set_goal(NewProcInfo7, Goal4, NewProcInfo8),
- proc_info_set_varset(NewProcInfo8, Varset, NewProcInfo9),
- proc_info_set_vartypes(NewProcInfo9, VarTypes, NewProcInfo),
+ proc_info_set_goal(NewProcInfo8, Goal4, NewProcInfo9),
+ proc_info_set_varset(NewProcInfo9, Varset, NewProcInfo10),
+ proc_info_set_vartypes(NewProcInfo10, VarTypes, NewProcInfo),
map__det_insert(NewProcs0, NewProcId, NewProcInfo, NewProcs),
- pred_info_set_procedures(NewPredInfo3, NewProcs, NewPredInfo),
+ pred_info_set_procedures(NewPredInfo4, NewProcs, NewPredInfo),
map__det_update(Preds0, NewPredId, NewPredInfo, Preds),
predicate_table_set_preds(PredTable0, Preds, PredTable),
module_info_set_predicate_table(ModuleInfo1, PredTable, ModuleInfo2),
@@ -1581,8 +2120,8 @@
list__append(ArgModes0, CurriedArgModes, ArgModes1),
list__append(HeadVars0, NewHeadVars, HeadVars1),
- construct_higher_order_terms(ModuleInfo, HeadVars1, HeadVars, ArgModes1,
- ArgModes, HOArgs, ProcInfo2, ProcInfo,
+ construct_higher_order_terms(ModuleInfo, HeadVars1, HeadVars,
+ ArgModes1, ArgModes, HOArgs, ProcInfo2, ProcInfo,
Renaming2, Renaming, PredVars2, PredVars).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_goal.m,v
retrieving revision 1.58
diff -u -u -r1.58 hlds_goal.m
--- hlds_goal.m 1999/03/22 08:07:11 1.58
+++ hlds_goal.m 1999/04/08 02:40:40
@@ -13,7 +13,7 @@
:- interface.
:- import_module hlds_data, hlds_pred, llds, prog_data, (inst), instmap.
-:- import_module list, set, map, std_util.
+:- import_module char, list, set, map, std_util.
% Here is how goals are represented
@@ -715,12 +715,76 @@
:- pred goal_list_determinism(list(hlds_goal), determinism).
:- mode goal_list_determinism(in, out) is det.
+ %
+ % Produce a goal to construct a given constant.
+ %
+
+:- pred make_int_const_construction(prog_var, int, hlds_goal).
+:- mode make_int_const_construction(in, in, out) is det.
+
+:- pred make_string_const_construction(prog_var, string, hlds_goal).
+:- mode make_string_const_construction(in, in, out) is det.
+
+:- pred make_float_const_construction(prog_var, float, hlds_goal).
+:- mode make_float_const_construction(in, in, out) is det.
+
+:- pred make_char_const_construction(prog_var, char, hlds_goal).
+:- mode make_char_const_construction(in, in, out) is det.
+
+:- pred make_const_construction(prog_var, cons_id, hlds_goal).
+:- mode make_const_construction(in, in, out) is det.
+
+:- pred make_int_const_construction(int, hlds_goal, prog_var,
+ map(prog_var, type), map(prog_var, type),
+ prog_varset, prog_varset).
+:- mode make_int_const_construction(in, out, out, in, out, in, out) is det.
+
+:- pred make_string_const_construction(string, hlds_goal, prog_var,
+ map(prog_var, type), map(prog_var, type),
+ prog_varset, prog_varset).
+:- mode make_string_const_construction(in, out, out, in, out, in, out) is det.
+
+:- pred make_float_const_construction(float, hlds_goal, prog_var,
+ map(prog_var, type), map(prog_var, type),
+ prog_varset, prog_varset).
+:- mode make_float_const_construction(in, out, out, in, out, in, out) is det.
+
+:- pred make_char_const_construction(char, hlds_goal, prog_var,
+ map(prog_var, type), map(prog_var, type),
+ prog_varset, prog_varset).
+:- mode make_char_const_construction(in, out, out, in, out, in, out) is det.
+
+:- pred make_const_construction(cons_id, (type), hlds_goal, prog_var,
+ map(prog_var, type), map(prog_var, type),
+ prog_varset, prog_varset).
+:- mode make_const_construction(in, in, out, out, in, out, in, out) is det.
+
+:- pred make_int_const_construction(int, hlds_goal, prog_var,
+ proc_info, proc_info).
+:- mode make_int_const_construction(in, out, out, in, out) is det.
+
+:- pred make_string_const_construction(string, hlds_goal, prog_var,
+ proc_info, proc_info).
+:- mode make_string_const_construction(in, out, out, in, out) is det.
+
+:- pred make_float_const_construction(float, hlds_goal, prog_var,
+ proc_info, proc_info).
+:- mode make_float_const_construction(in, out, out, in, out) is det.
+
+:- pred make_char_const_construction(char, hlds_goal, prog_var,
+ proc_info, proc_info).
+:- mode make_char_const_construction(in, out, out, in, out) is det.
+
+:- pred make_const_construction(cons_id, (type), hlds_goal, prog_var,
+ proc_info, proc_info).
+:- mode make_const_construction(in, in, out, out, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module det_analysis, term.
-:- import_module require.
+:- import_module det_analysis, type_util.
+:- import_module require, string, term, varset.
goal_info_init(GoalInfo) :-
Detism = erroneous,
@@ -1031,6 +1095,83 @@
det_conjunction_detism(Det0, Det1, Det)
)),
list__foldl(ComputeDeterminism, Goals, det, Determinism).
+
+%-----------------------------------------------------------------------------%
+
+make_int_const_construction(Int, Goal, Var, ProcInfo0, ProcInfo) :-
+ proc_info_create_var_from_type(ProcInfo0, int_type, Var, ProcInfo),
+ make_int_const_construction(Var, Int, Goal).
+
+make_string_const_construction(String, Goal, Var, ProcInfo0, ProcInfo) :-
+ proc_info_create_var_from_type(ProcInfo0, string_type, Var, ProcInfo),
+ make_string_const_construction(Var, String, Goal).
+
+make_float_const_construction(Float, Goal, Var, ProcInfo0, ProcInfo) :-
+ proc_info_create_var_from_type(ProcInfo0, float_type, Var, ProcInfo),
+ make_float_const_construction(Var, Float, Goal).
+
+make_char_const_construction(Char, Goal, Var, ProcInfo0, ProcInfo) :-
+ proc_info_create_var_from_type(ProcInfo0, char_type, Var, ProcInfo),
+ make_char_const_construction(Var, Char, Goal).
+
+make_const_construction(ConsId, Type, Goal, Var, ProcInfo0, ProcInfo) :-
+ proc_info_create_var_from_type(ProcInfo0, Type, Var, ProcInfo),
+ make_const_construction(Var, ConsId, Goal).
+
+make_int_const_construction(Int, Goal, Var, VarTypes0, VarTypes,
+ VarSet0, VarSet) :-
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, int_type, VarTypes),
+ make_int_const_construction(Var, Int, Goal).
+
+make_string_const_construction(String, Goal, Var, VarTypes0, VarTypes,
+ VarSet0, VarSet) :-
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, string_type, VarTypes),
+ make_string_const_construction(Var, String, Goal).
+
+make_float_const_construction(Float, Goal, Var, VarTypes0, VarTypes,
+ VarSet0, VarSet) :-
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, float_type, VarTypes),
+ make_float_const_construction(Var, Float, Goal).
+
+make_char_const_construction(Char, Goal, Var, VarTypes0, VarTypes,
+ VarSet0, VarSet) :-
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, char_type, VarTypes),
+ make_char_const_construction(Var, Char, Goal).
+
+make_const_construction(ConsId, Type, Goal, Var, VarTypes0, VarTypes,
+ VarSet0, VarSet) :-
+ varset__new_var(VarSet0, Var, VarSet),
+ map__det_insert(VarTypes0, Var, Type, VarTypes),
+ make_const_construction(Var, ConsId, Goal).
+
+make_int_const_construction(Var, Int, Goal) :-
+ make_const_construction(Var, int_const(Int), Goal).
+
+make_string_const_construction(Var, String, Goal) :-
+ make_const_construction(Var, string_const(String), Goal).
+
+make_float_const_construction(Var, Float, Goal) :-
+ make_const_construction(Var, float_const(Float), Goal).
+
+make_char_const_construction(Var, Char, Goal) :-
+ string__char_to_string(Char, String),
+ make_const_construction(Var, cons(unqualified(String), 0), Goal).
+
+make_const_construction(Var, ConsId, Goal - GoalInfo) :-
+ RHS = functor(ConsId, []),
+ Inst = bound(unique, [functor(ConsId, [])]),
+ Mode = (free -> Inst) - (Inst -> Inst),
+ Unification = construct(Var, ConsId, [], []),
+ Context = unify_context(explicit, []),
+ Goal = unify(Var, RHS, Mode, Unification, Context),
+ set__singleton_set(NonLocals, Var),
+ instmap_delta_init_reachable(InstMapDelta0),
+ instmap_delta_insert(InstMapDelta0, Var, Inst, InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, GoalInfo).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_module.m,v
retrieving revision 1.42
diff -u -u -r1.42 hlds_module.m
--- hlds_module.m 1999/04/08 08:41:04 1.42
+++ hlds_module.m 1999/04/09 06:59:25
@@ -24,13 +24,13 @@
:- import_module hlds_pred, hlds_data, prog_data, unify_proc, special_pred.
:- import_module globals, llds, continuation_info.
-:- import_module relation, map, std_util, list, set.
+:- import_module relation, map, std_util, list, set, multi_map.
:- implementation.
-:- import_module hlds_out, prog_out, prog_data, prog_util.
+:- import_module hlds_out, prog_out, prog_util.
:- import_module typecheck, modules.
-:- import_module bool, require, int, string, set, multi_map.
+:- import_module bool, require, int, string.
%-----------------------------------------------------------------------------%
@@ -83,10 +83,36 @@
hlds_type_defn % defn of type
).
- % Various predicates for manipulating the module_info data structure
% map from proc to a list of unused argument numbers.
:- type unused_arg_info == map(pred_proc_id, list(int)).
+ % List of procedures for which there are user-requested type
+ % specializations, and a list of predicates which should be
+ % processed by higher_order.m to ensure the production of those
+ % versions.
+:- type type_spec_info
+ ---> type_spec_info(
+ set(pred_proc_id), % Procedures for which there are
+ % user-requested type specializations.
+ set(pred_id), % Set of procedures which need to be
+ % processed by higher_order.m to
+ % produce those specialized versions.
+ multi_map(pred_id, pred_id),
+ % Map from predicates for which the
+ % user requested a type specialization
+ % to the list of predicates which must
+ % be processed by higher_order.m to
+ % force the production of those
+ % versions. This is used by
+ % dead_proc_elim.m to avoid creating
+ % versions unnecessarily for versions
+ % in imported modules.
+ multi_map(pred_id, pragma_type)
+ % Type spec pragmas to be placed in
+ % the `.opt' file if a predicate
+ % becomes exported.
+ ).
+
% This field should be set to `do_aditi_compilation' if there
% are local Aditi predicates.
:- type do_aditi_compilation
@@ -95,6 +121,8 @@
%-----------------------------------------------------------------------------%
+ % Various predicates for manipulating the module_info data structure
+
% Create an empty module_info for a given module name (and the
% global options).
@@ -266,6 +294,13 @@
:- pred module_info_set_do_aditi_compilation(module_info, module_info).
:- mode module_info_set_do_aditi_compilation(in, out) is det.
+:- pred module_info_type_spec_info(module_info, type_spec_info).
+:- mode module_info_type_spec_info(in, out) is det.
+
+:- pred module_info_set_type_spec_info(module_info,
+ type_spec_info, module_info).
+:- mode module_info_set_type_spec_info(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- pred module_info_preds(module_info, pred_table).
@@ -450,6 +485,9 @@
do_aditi_compilation).
:- mode module_sub_get_do_aditi_compilation(in, out) is det.
+:- pred module_sub_get_type_spec_info(module_sub_info, type_spec_info).
+:- mode module_sub_get_type_spec_info(in, out) is det.
+
:- pred module_sub_set_c_header_info(module_sub_info, c_header_info,
module_sub_info).
:- mode module_sub_set_c_header_info(in, in, out) is det.
@@ -499,6 +537,10 @@
:- pred module_sub_set_do_aditi_compilation(module_sub_info, module_sub_info).
:- mode module_sub_set_do_aditi_compilation(in, out) is det.
+:- pred module_sub_set_type_spec_info(module_sub_info,
+ type_spec_info, module_sub_info).
+:- mode module_sub_set_type_spec_info(in, in, out) is det.
+
:- type module_info
---> module(
module_sub_info,
@@ -547,9 +589,12 @@
set(module_specifier),
% All the imported module specifiers
% (used during type checking).
- do_aditi_compilation
+ do_aditi_compilation,
% are there any local Aditi predicates
% for which Aditi-RL must be produced.
+ type_spec_info
+ % data used for user-guided type
+ % specialization.
).
% A predicate which creates an empty module
@@ -565,13 +610,21 @@
map__init(Ctors),
set__init(StratPreds),
map__init(UnusedArgInfo),
+
+ set__init(TypeSpecPreds),
+ set__init(TypeSpecForcePreds),
+ map__init(SpecMap),
+ map__init(PragmaMap),
+ TypeSpecInfo = type_spec_info(TypeSpecPreds,
+ TypeSpecForcePreds, SpecMap, PragmaMap),
+
map__init(ClassTable),
map__init(InstanceTable),
map__init(SuperClassTable),
set__init(ModuleNames),
ModuleSubInfo = module_sub(Name, Globals, [], [], no, 0, 0, [],
[], [], StratPreds, UnusedArgInfo, 0, ModuleNames,
- no_aditi_compilation),
+ no_aditi_compilation, TypeSpecInfo),
ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests,
UnifyPredMap, GlobalData, Types, Insts, Modes, Ctors,
ClassTable, SuperClassTable, InstanceTable, 0).
@@ -609,6 +662,7 @@
% O do_aditi_compilation
% % are there any local Aditi predicates
% % for which Aditi-RL must be produced.
+% P type_spec_info
% ).
%-----------------------------------------------------------------------------%
@@ -616,110 +670,117 @@
% Various predicates which access the module_sub_info data structure.
module_sub_get_name(MI0, A) :-
- MI0 = module_sub(A, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
module_sub_get_globals(MI0, B) :-
- MI0 = module_sub(_, B, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
module_sub_get_c_header_info(MI0, C) :-
- MI0 = module_sub(_, _, C, _, _, _, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, C, _, _, _, _, _, _, _, _, _, _, _, _, _).
module_sub_get_c_body_info(MI0, D) :-
- MI0 = module_sub(_, _, _, D, _, _, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, D, _, _, _, _, _, _, _, _, _, _, _, _).
module_sub_get_maybe_dependency_info(MI0, E) :-
- MI0 = module_sub(_, _, _, _, E, _, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, E, _, _, _, _, _, _, _, _, _, _, _).
module_sub_get_num_errors(MI0, F) :-
- MI0 = module_sub(_, _, _, _, _, F, _, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, F, _, _, _, _, _, _, _, _, _, _).
module_sub_get_lambda_count(MI0, G) :-
- MI0 = module_sub(_, _, _, _, _, _, G, _, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, G, _, _, _, _, _, _, _, _, _).
module_sub_get_pragma_exported_procs(MI0, H) :-
- MI0 = module_sub(_, _, _, _, _, _, _, H, _, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, H, _, _, _, _, _, _, _, _).
module_sub_get_base_gen_infos(MI0, I) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, I, _, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, I, _, _, _, _, _, _, _).
module_sub_get_base_gen_layouts(MI0, J) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, J, _, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, J, _, _, _, _, _, _).
module_sub_get_stratified_preds(MI0, K) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, K, _, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, K, _, _, _, _, _).
module_sub_get_unused_arg_info(MI0, L) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, L, _, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, L, _, _, _, _).
module_sub_get_model_non_pragma_count(MI0, M) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, M, _, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, M, _, _, _).
module_sub_get_imported_module_specifiers(MI0, N) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, N, _).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, N, _, _).
module_sub_get_do_aditi_compilation(MI0, O) :-
- MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, O).
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, O, _).
+
+module_sub_get_type_spec_info(MI0, P) :-
+ MI0 = module_sub(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, P).
%-----------------------------------------------------------------------------%
% Various predicates which modify the module_sub_info data structure.
module_sub_set_globals(MI0, B, MI) :-
- MI0 = module_sub(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_c_header_info(MI0, C, MI) :-
- MI0 = module_sub(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, _, D, E, F, G, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_c_body_info(MI0, D, MI) :-
- MI0 = module_sub(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_maybe_dependency_info(MI0, E, MI) :-
- MI0 = module_sub(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_num_errors(MI0, F, MI) :-
- MI0 = module_sub(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, _, G, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_lambda_count(MI0, G, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, _, H, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_pragma_exported_procs(MI0, H, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, _, I, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, _, I, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_base_gen_infos(MI0, I, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, _, J, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_base_gen_layouts(MI0, J, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_stratified_preds(MI0, K, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_unused_arg_info(MI0, L, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_model_non_pragma_count(MI0, M, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_imported_module_specifiers(MI0, N, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O),
- MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O).
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, _, O, P),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
module_sub_set_do_aditi_compilation(MI0, MI) :-
- MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _),
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, P),
MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- do_aditi_compilation).
+ do_aditi_compilation, P).
+
+module_sub_set_type_spec_info(MI0, P, MI) :-
+ MI0 = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, _),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P).
%-----------------------------------------------------------------------------%
@@ -903,6 +964,10 @@
module_info_get_sub_info(MI0, MS0),
module_sub_get_imported_module_specifiers(MS0, N).
+module_info_type_spec_info(MI0, P) :-
+ module_info_get_sub_info(MI0, MS0),
+ module_sub_get_type_spec_info(MS0, P).
+
module_info_get_do_aditi_compilation(MI0, O) :-
module_info_get_sub_info(MI0, MS0),
module_sub_get_do_aditi_compilation(MS0, O).
@@ -982,6 +1047,11 @@
module_info_set_do_aditi_compilation(MI0, MI) :-
module_info_get_sub_info(MI0, MS0),
module_sub_set_do_aditi_compilation(MS0, MS),
+ module_info_set_sub_info(MI0, MS, MI).
+
+module_info_set_type_spec_info(MI0, P, MI) :-
+ module_info_get_sub_info(MI0, MS0),
+ module_sub_set_type_spec_info(MS0, P, MS),
module_info_set_sub_info(MI0, MS, MI).
%-----------------------------------------------------------------------------%
More information about the developers
mailing list