for review: type specialization [1]
Simon Taylor
stayl at cs.mu.OZ.AU
Wed Feb 17 12:24:56 AEDT 1999
Hi,
Could someone (Fergus?) please review this?
I'll fix the demangler as a separate change.
There's another diff coming later with type specialization declarations
for the library - that has to wait until this diff is installed. An entry
for the news section of the web page can wait until then.
Thanks,
Simon.
Estimated hours taken: 35
User-guided type specialization.
compiler/prog_data.m:
compiler/prog_prog_io_pragma.m:
compiler/modules.m:
compiler/module_qual.m:
compiler/mercury_to_mercury.m:
Added `pragma type_spec(<predicate>, <type substitution>)'.
compiler/prog_prog_io_pragma.m:
Thread a counter through the pragma parsing so that unique
specialised predicate names can be allocated and placed in
the `.int' files. This avoids having to create and read in
`.opt' files to use the `pragma type_spec' declarations for
imported modules.
Factor out some common code to parse predicate names with arguments
that was useful for `pragma type_spec'.
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', 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).
compiler/dead_proc_elim.m:
Remove specializations for dead procedures.
NEWS:
doc/reference_manual.texi:
doc/user_guide.texi:
Document the pragmas and new options.
Index: NEWS
===================================================================
RCS file: /home/staff/zs/imp/mercury/NEWS,v
retrieving revision 1.132
diff -u -r1.132 NEWS
--- NEWS 1998/12/06 06:23:38 1.132
+++ NEWS 1999/02/17 00:48:57
@@ -10,3 +10,8 @@
which are supported by most modern Unix systems.
See the files in extras/dynamic_linking for details.
+* 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/dead_proc_elim.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.43
diff -u -r1.43 dead_proc_elim.m
--- dead_proc_elim.m 1998/11/02 09:48:58 1.43
+++ dead_proc_elim.m 1999/02/10 05:01:04
@@ -686,12 +686,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.17
diff -u -r1.17 equiv_type.m
--- equiv_type.m 1998/11/20 04:07:32 1.17
+++ equiv_type.m 1999/02/10 05:01:05
@@ -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.70
diff -u -r1.70 handle_options.m
--- handle_options.m 1998/12/09 03:26:21 1.70
+++ handle_options.m 1999/02/10 05:01:07
@@ -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.49
diff -u -r1.49 higher_order.m
--- higher_order.m 1998/12/06 23:43:15 1.49
+++ higher_order.m 1999/02/10 05:01:07
@@ -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,30 +39,64 @@
:- 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.
-:- 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, GoalSizes1, GoalSizes2,
+ 1, NextHOid, NewPreds0, NewPreds1, ModuleInfo1, ModuleInfo2),
+ { get_specialization_requests(Params, PredIds, NewPreds1,
+ Requests0, Requests, GoalSizes2, GoalSizes,
+ ModuleInfo2, ModuleInfo3) },
+ 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) }.
:- 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.
+ 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, GoalSizes0, NextHOid0, NextHOid,
+process_requests(Params, Requests0, GoalSizes0, GoalSizes, NextHOid0, NextHOid,
NewPreds0, NewPreds, ModuleInfo1, ModuleInfo) -->
{ filter_requests(Params, ModuleInfo1,
Requests0, GoalSizes0, Requests) },
@@ -75,17 +105,18 @@
->
{ ModuleInfo = ModuleInfo1 },
{ NextHOid = NextHOid0 },
- { NewPreds = NewPreds0 }
+ { NewPreds = NewPreds0 },
+ { GoalSizes = GoalSizes0 }
;
{ set__init(PredProcsToFix0) },
- create_new_preds(Requests, NewPreds0, NewPreds1,
+ create_new_preds(Params, Requests, NewPreds0, NewPreds1,
[], NewPredList, PredProcsToFix0, PredProcsToFix,
NextHOid0, NextHOid1, ModuleInfo1, ModuleInfo2),
{ set__to_sorted_list(PredProcsToFix, PredProcs) },
{ set__init(NewRequests0) },
{ create_specialized_versions(Params, NewPredList,
NewPreds1, NewPreds2, NewRequests0, NewRequests,
- GoalSizes0, GoalSizes, ModuleInfo2, ModuleInfo3) },
+ GoalSizes0, GoalSizes1, ModuleInfo2, ModuleInfo3) },
{ fixup_preds(Params, PredProcs, NewPreds2,
ModuleInfo3, ModuleInfo4) },
@@ -98,8 +129,9 @@
;
ModuleInfo5 = ModuleInfo4
},
- process_requests(Params, NewRequests, GoalSizes, NextHOid1,
- NextHOid, NewPreds2, NewPreds, ModuleInfo5, ModuleInfo)
+ process_requests(Params, NewRequests, GoalSizes1, GoalSizes,
+ NextHOid1, NextHOid, NewPreds2, NewPreds,
+ ModuleInfo5, ModuleInfo)
).
%-------------------------------------------------------------------------------
@@ -115,7 +147,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
@@ -174,7 +208,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 +235,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.
@@ -209,25 +247,15 @@
; unchanged. % Do nothing more for this predicate
%-------------------------------------------------------------------------------
-:- pred get_specialization_requests(ho_params::in, set(request)::out,
- 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(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.
-:- 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,11 +271,8 @@
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)),
@@ -266,8 +291,8 @@
(Changed = request ; Changed = changed)
->
traverse_other_procs(Params, PredId, ProcIds,
- ModuleInfo0, PredInfo0, Requests1, Requests2,
- Procs1, Procs),
+ ModuleInfo0, PredInfo0, NewPreds,
+ Requests1, Requests2, Procs1, Procs),
pred_info_set_procedures(PredInfo0, Procs, PredInfo),
map__det_update(Preds0, PredId, PredInfo, Preds),
module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1)
@@ -276,28 +301,26 @@
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, 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).
+ _, Requests, Requests, Procs, Procs).
traverse_other_procs(Params, PredId, [ProcId | ProcIds], ModuleInfo,
- PredInfo0, Requests0, Requests, Procs0, Procs) :-
+ PredInfo0, 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, _,_,_,_,_,_,_)),
@@ -311,7 +334,7 @@
proc_info_set_vartypes(ProcInfo2, VarTypes, ProcInfo),
map__det_update(Procs0, ProcId, ProcInfo, Procs1),
traverse_other_procs(Params, PredId, ProcIds, ModuleInfo, PredInfo0,
- Requests1, Requests, Procs1, Procs).
+ NewPreds, Requests1, Requests, Procs1, Procs).
%-------------------------------------------------------------------------------
% Goal traversal
@@ -322,6 +345,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) ->
@@ -553,20 +577,21 @@
:- 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, _), base_type_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, _, _),
+ base_type_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.
@@ -672,30 +697,39 @@
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),
+ find_higher_order_args(Module, CalleeStatus, Args0,
+ CalleeArgTypes, VarTypes, PredVars, 1, [],
+ HigherOrderArgs0),
( HigherOrderArgs0 = [] ->
Info = Info0,
Goal = Goal0
;
list__reverse(HigherOrderArgs0, HigherOrderArgs),
find_matching_version(Info0, CalledPred, CalledProc,
- Args0, Args1, HigherOrderArgs, FindResult),
+ Args0, HigherOrderArgs, 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,11 +741,16 @@
% 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)
@@ -719,22 +758,18 @@
).
% 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 +785,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,150 +803,255 @@
;
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).
:- 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,
+ pred_id::in, proc_id::in, list(prog_var)::in,
list(higher_order_arg)::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,
+find_matching_version(Info, CalledPred, CalledProc, Args0,
HigherOrderArgs, 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),
- ( TypeInfoLiveness = yes ->
- set__list_to_set(Args1, NonLocals0),
- proc_info_typeinfo_varmap(ProcInfo, TVarMap),
- proc_info_typeclass_info_varmap(ProcInfo, TCVarMap),
- goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap,
- VarTypes, ExistQVars, NonLocals0, TypeInfos0),
- set__delete_list(TypeInfos0, Args1, ExtraTypeInfos0),
- set__to_sorted_list(ExtraTypeInfos0, ExtraTypeInfos),
- map__apply_to_list(ExtraTypeInfos,
- VarTypes, ExtraTypeInfoTypes)
+ module_info_type_spec_info(ModuleInfo,
+ type_spec_info(_, ForceVersions, _, _)),
+
+ Caller = proc(CallerPredId, _),
+ ( set__member(CallerPredId, ForceVersions) ->
+ IsUserSpecProc = yes
;
- ExtraTypeInfos = [],
- ExtraTypeInfoTypes = []
+ IsUserSpecProc = no
),
- map__apply_to_list(Args0, VarTypes, CallArgTypes),
Request = request(Caller, proc(CalledPred, CalledProc), Args0,
ExtraTypeInfos, HigherOrderArgs, CallArgTypes,
- ExtraTypeInfoTypes, TVarSet),
+ 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),
- NewPredSet),
- set__to_sorted_list(NewPredSet, NewPredList),
- search_for_version(TypeInfoLiveness, ModuleInfo, Request,
- ExtraTypeInfos, NewPredList,
- Match, OrderedExtraTypeInfos)
+ Versions0),
+ set__to_sorted_list(Versions0, Versions),
+ search_for_version(Info, Params, ModuleInfo, Request, Args0,
+ Versions, no, Match)
->
- Result = match(Match, OrderedExtraTypeInfos)
+ Result = match(Match)
;
+ Params = ho_params(HigherOrder, TypeSpec, UserTypeSpec, _, _),
+ (
+ UserTypeSpec = yes,
+ IsUserSpecProc = yes
+ ;
+ HigherOrder = yes,
+ module_info_pred_info(ModuleInfo,
+ CalledPred, CalledPredInfo),
+ \+ pred_info_is_imported(CalledPredInfo),
+ list__member(HOArg, HigherOrderArgs),
+ HOArg = higher_order_arg(pred_const(_, _),
+ _, _, _, _, _)
+ ;
+ TypeSpec = yes,
+ module_info_pred_info(ModuleInfo,
+ CalledPred, CalledPredInfo),
+ \+ pred_info_is_imported(CalledPredInfo)
+ )
+ ->
Result = request(Request)
+ ;
+ Result = no_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.
+:- 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, _),
-search_for_version(TypeInfoLiveness, ModuleInfo, Request, ExtraTypeInfos,
- [Version | Versions], Match, OrderedExtraTypeInfos) :-
+ Params = ho_params(_, _, _, _, TypeInfoLiveness),
+ ( TypeInfoLiveness = yes ->
+ set__list_to_set(Args1, NonLocals0),
+ proc_info_typeinfo_varmap(ProcInfo, TVarMap),
+ proc_info_typeclass_info_varmap(ProcInfo, TCVarMap),
+ goal_util__extra_nonlocal_typeinfos(TVarMap, TCVarMap,
+ VarTypes, ExistQVars, NonLocals0, TypeInfos0),
+ set__delete_list(TypeInfos0, Args1, ExtraTypeInfos0),
+ set__to_sorted_list(ExtraTypeInfos0, ExtraTypeInfos),
+ map__apply_to_list(ExtraTypeInfos,
+ VarTypes, ExtraTypeInfoTypes)
+ ;
+ ExtraTypeInfos = [],
+ ExtraTypeInfoTypes = []
+ ).
+
+:- 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 +1088,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
@@ -1099,22 +1283,22 @@
set(request)::in, goal_sizes::in, list(request)::out) is det.
filter_requests(Params, ModuleInfo, Requests0, GoalSizes, Requests) :-
- Params = ho_params(_, _, MaxSize),
set__to_sorted_list(Requests0, Requests1),
+ Params = ho_params(_, _, _, MaxSize, _),
list__filter(lambda([X::in] is semidet, (
- X = request(_, CalledPredProcId, _, _, _, _, _, _),
- CalledPredProcId = proc(CalledPredId,
- CalledProcId),
+ X = request(_, CalledPredProcId, _, _, _,
+ _, _, _, IsUserTypeSpec),
+ CalledPredProcId = proc(CalledPredId, _),
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)
+ (
+ % Ignore the size limit for user
+ % specified specializations.
+ IsUserTypeSpec = yes
+ ;
+ map__search(GoalSizes, CalledPredId, GoalSize),
+ GoalSize =< MaxSize
),
- map__search(GoalSizes, CalledPredId, GoalSize),
- GoalSize =< MaxSize,
pred_info_name(PredInfo, PredName),
\+ (
% There are probably cleaner ways to check
@@ -1128,38 +1312,36 @@
)),
Requests1, Requests).
-:- 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 +1349,7 @@
Module1 = Module0,
NewPredList1 = NewPredList0,
NewPreds1 = NewPreds0,
- IO2 = IO1,
+ IO2 = IO0,
NextHOid1 = NextHOid0
)
;
@@ -1176,7 +1358,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 +1381,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),
@@ -1212,13 +1395,37 @@
IOState0, IOState1),
pred_info_arg_types(PredInfo0, ArgTVarSet, ExistQVars, Types),
string__int_to_string(Arity, ArStr),
+
+ ( 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),
(
VeryVerbose = yes
->
prog_out__sym_name_to_string(PredModule, PredModuleString),
+ unqualify_name(SymName, NewName),
io__write_strings(["% Specializing calls to `",
PredModuleString, ":", Name0, "'/", ArStr,
- " with higher-order arguments:\n"],
+ " into ", NewName, " with higher-order arguments:\n"],
IOState1, IOState2),
list__length(Types, ActualArity),
NumToDrop is ActualArity - Arity,
@@ -1227,16 +1434,12 @@
;
IOState = IOState1
),
- string__int_to_string(NextHOid0, IdStr),
- NextHOid is NextHOid0 + 1,
- string__append_list([Name0, "__ho", IdStr], PredName),
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 +1448,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,8 +1457,8 @@
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 output_higher_order_args(module_info::in, int::in,
list(higher_order_arg)::in, io__state::di, io__state::uo) is det.
@@ -1275,9 +1478,20 @@
io__write_string(Name),
io__write_string("'/"),
io__write_int(Arity)
+ ; { ConsId = base_type_info_const(TypeModule, TypeName, TypeArity) } ->
+ io__write_string(" base_type_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),
@@ -1329,7 +1543,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,
@@ -1581,8 +1795,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_module.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_module.m,v
retrieving revision 1.39
diff -u -r1.39 hlds_module.m
--- hlds_module.m 1998/12/06 23:43:17 1.39
+++ hlds_module.m 1999/02/10 05:01:07
@@ -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.
%-----------------------------------------------------------------------------%
@@ -82,10 +82,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
@@ -94,6 +120,8 @@
%-----------------------------------------------------------------------------%
+ % Various predicates for manipulating the module_info data structure
+
% Create an empty module_info for a given module name (and the
% global options).
@@ -265,6 +293,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).
@@ -449,6 +484,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.
@@ -498,6 +536,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,
@@ -546,9 +588,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
@@ -564,13 +609,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).
@@ -608,6 +661,7 @@
% O do_aditi_compilation
% % are there any local Aditi predicates
% % for which Aditi-RL must be produced.
+% P type_spec_info
% ).
%-----------------------------------------------------------------------------%
@@ -615,110 +669,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).
%-----------------------------------------------------------------------------%
@@ -902,6 +963,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).
@@ -981,6 +1046,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).
%-----------------------------------------------------------------------------%
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.63
diff -u -r1.63 intermod.m
--- intermod.m 1998/12/06 23:43:25 1.63
+++ intermod.m 1999/02/10 05:01:08
@@ -60,8 +60,8 @@
:- implementation.
-:- import_module assoc_list, dir, getopt, int, list, map, require, set.
-:- import_module std_util, string.
+:- import_module assoc_list, dir, getopt, int, list, map, multi_map, require.
+:- import_module set, std_util, string, term, varset.
:- import_module code_util, globals, goal_util, term, varset.
:- import_module hlds_data, hlds_goal, hlds_pred, hlds_out, inlining, llds.
@@ -167,6 +167,8 @@
intermod_info_get_module_info(ModuleInfo0),
{ module_info_preds(ModuleInfo0, PredTable0) },
{ map__lookup(PredTable0, PredId, PredInfo0) },
+ { module_info_type_spec_info(ModuleInfo0, TypeSpecInfo) },
+ { TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _) },
(
%
% note: we can't include exported_to_submodules predicates
@@ -183,6 +185,9 @@
% recreated in the importing module anyway.
{ \+ code_util__compiler_generated(PredInfo0) },
{ \+ code_util__predinfo_is_builtin(PredInfo0) },
+
+ % These will be recreated in the importing module.
+ { \+ set__member(PredId, TypeSpecForcePreds) },
(
{ inlining__is_simple_goal(Goal,
InlineThreshold) },
@@ -1010,6 +1015,8 @@
{ list__sort(CompareProcId, ProcIds, SortedProcIds) },
intermod__write_pred_modes(Procs, qualified(Module, Name),
PredOrFunc, SortedProcIds),
+ intermod__write_pragmas(PredInfo),
+ intermod__write_type_spec_pragmas(ModuleInfo, PredId),
intermod__write_pred_decls(ModuleInfo, PredIds).
:- pred intermod__write_pred_modes(map(proc_id, proc_info)::in,
@@ -1048,15 +1055,14 @@
intermod__write_preds(_, []) --> [].
intermod__write_preds(ModuleInfo, [PredId | PredIds]) -->
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
- { pred_info_arg_types(PredInfo, ArgTypes) },
- { list__length(ArgTypes, Arity) },
{ pred_info_module(PredInfo, Module) },
{ pred_info_name(PredInfo, Name) },
{ SymName = qualified(Module, Name) },
- { pred_info_get_markers(PredInfo, Markers) },
- { markers_to_marker_list(Markers, MarkerList) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
- intermod__write_pragmas(SymName, Arity, MarkerList, PredOrFunc),
+ intermod__write_pragmas(PredInfo),
+ % The type specialization pragmas for exported preds should
+ % already be in the interface file.
+
{ pred_info_clauses_info(PredInfo, ClausesInfo) },
{ ClausesInfo = clauses_info(Varset, _, _VarTypes, HeadVars, Clauses) },
% handle pragma c_code(...) separately
@@ -1072,6 +1078,20 @@
),
intermod__write_preds(ModuleInfo, PredIds).
+
+:- pred intermod__write_pragmas(pred_info::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_pragmas(PredInfo) -->
+ { pred_info_module(PredInfo, Module) },
+ { pred_info_name(PredInfo, Name) },
+ { pred_info_arity(PredInfo, Arity) },
+ { SymName = qualified(Module, Name) },
+ { pred_info_get_markers(PredInfo, Markers) },
+ { markers_to_marker_list(Markers, MarkerList) },
+ { pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ intermod__write_pragmas(SymName, Arity, MarkerList, PredOrFunc).
+
:- pred intermod__write_pragmas(sym_name::in, int::in, list(marker)::in,
pred_or_func::in, io__state::di, io__state::uo) is det.
@@ -1085,6 +1105,21 @@
[]
),
intermod__write_pragmas(SymName, Arity, Markers, PredOrFunc).
+
+:- pred intermod__write_type_spec_pragmas(module_info::in, pred_id::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_type_spec_pragmas(ModuleInfo, PredId) -->
+ { module_info_type_spec_info(ModuleInfo,
+ type_spec_info(_, _, _, PragmaMap)) },
+ ( { multi_map__search(PragmaMap, PredId, TypeSpecPragmas) } ->
+ { term__context_init(Context) },
+ list__foldl(lambda([Pragma::in, IO0::di, IO::uo] is det, (
+ mercury_output_item(pragma(Pragma), Context, IO0, IO)
+ )), TypeSpecPragmas)
+ ;
+ []
+ ).
% Is a pragma declaration required in the `.opt' file for
% a predicate with the given marker.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.281
diff -u -r1.281 make_hlds.m
--- make_hlds.m 1999/02/08 22:42:45 1.281
+++ make_hlds.m 1999/02/10 05:48:06
@@ -387,6 +387,12 @@
)
;
+ { Pragma = type_spec(Name, SpecName, Arity, PorF,
+ MaybeModes, TypeSubst, VarSet) },
+ add_pragma_type_spec(Pragma, Name, SpecName, Arity, PorF,
+ MaybeModes, TypeSubst, VarSet,
+ Context, Module0, Module)
+ ;
% Handle pragma fact_table decls later on (when we process
% clauses).
{ Pragma = fact_table(_, _, _) },
@@ -750,6 +756,375 @@
io__write_string(
"Internal compiler error: unknown predicate in `pragma unused_args'.\n"),
{ module_info_incr_errors(Module0, Module) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_pragma_type_spec(pragma_type, sym_name, sym_name, arity,
+ maybe(pred_or_func), maybe(list(mode)), assoc_list(tvar, type),
+ tvarset, term__context, module_info, module_info,
+ io__state, io__state).
+:- mode add_pragma_type_spec(in, in, in, in, in, in, in,
+ in, in, in, out, di, uo) is det.
+
+add_pragma_type_spec(Pragma, SymName, SpecName, Arity, MaybePredOrFunc,
+ MaybeModes, SpecSubst, VarSet, Context, Module0, Module) -->
+ { module_info_get_predicate_table(Module0, Preds) },
+ (
+ { MaybePredOrFunc = yes(PredOrFunc) ->
+ predicate_table_search_pf_sym_arity(Preds,
+ PredOrFunc, SymName, Arity, PredIds)
+ ;
+ predicate_table_search_sym_arity(Preds,
+ SymName, Arity, PredIds)
+ }
+ ->
+ ( { PredIds = [PredId] } ->
+ add_pragma_type_spec_2(Pragma, SymName, SpecName,
+ Arity, SpecSubst, MaybeModes, VarSet, Context,
+ PredId, Module0, Module)
+ ;
+ % XXX we should allow the programmer to specify
+ % predicate or function to avoid this problem.
+ % It's difficult to just specialize all matching names
+ % because we've only included a single specialized
+ % name in the interface file.
+ { Module = Module0 },
+ io__set_exit_status(1),
+ prog_out__write_context(Context),
+ io__write_string(
+ "Error: `pragma type_spec' declaration matches\n"),
+ prog_out__write_context(Context),
+ io__write_string(
+ " multiple predicates or functions.\n")
+ )
+ ;
+ undefined_pred_or_func_error(SymName, Arity, Context,
+ "pragma type_spec declaration"),
+ { Module = Module0 }
+ ).
+
+:- pred add_pragma_type_spec_2(pragma_type, sym_name, sym_name, arity,
+ assoc_list(tvar, type), maybe(list(mode)), tvarset,
+ prog_context, pred_id, module_info, module_info, io__state, io__state).
+:- mode add_pragma_type_spec_2(in, in, in, in, in, in, in, in,
+ in, in, out, di, uo) is det.
+
+add_pragma_type_spec_2(Pragma, SymName, SpecName, Arity,
+ Subst, MaybeModes, TVarSet0, Context, PredId,
+ ModuleInfo0, ModuleInfo) -->
+ { module_info_pred_info(ModuleInfo0, PredId, PredInfo0) },
+ handle_pragma_type_spec_subst(Context, Subst, TVarSet0, PredInfo0,
+ TVarSet, Types, ExistQVars, ClassContext, SubstOk,
+ ModuleInfo0, ModuleInfo1),
+ ( { SubstOk = yes } ->
+ { pred_info_procedures(PredInfo0, Procs0) },
+ handle_pragma_type_spec_modes(SymName, Arity, Context,
+ MaybeModes, ProcIds, Procs0, Procs, ModesOk,
+ ModuleInfo1, ModuleInfo2),
+ globals__io_lookup_bool_option(user_guided_type_specialization,
+ DoTypeSpec),
+ {
+ ModesOk = yes,
+ % Even if we aren't doing type specialization, we need
+ % to create the interface procedures for local predicates
+ % to check the type-class correctness of the requested
+ % specializations.
+ ( DoTypeSpec = yes
+ ; \+ pred_info_is_imported(PredInfo0)
+ )
+ ->
+ %
+ % Build a clause to call the old predicate with the
+ % specified types to force the specialization. For imported
+ % predicates this forces the creation of the proper interface.
+ %
+ varset__init(ArgVarSet0),
+ varset__new_vars(ArgVarSet0, Arity, Args, ArgVarSet),
+ map__from_corresponding_lists(Args, Types, VarTypes0),
+ goal_info_init(GoalInfo0),
+ set__list_to_set(Args, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
+ goal_info_set_context(GoalInfo1, Context, GoalInfo),
+ invalid_proc_id(DummyProcId),
+ Goal = call(PredId, DummyProcId, Args,
+ not_builtin, no, SymName) - GoalInfo,
+ Clause = clause(ProcIds, Goal, Context),
+ Clauses = clauses_info(ArgVarSet, VarTypes0,
+ VarTypes0, Args, [Clause]),
+ pred_info_get_markers(PredInfo0, Markers),
+ map__init(Proofs),
+ ( pred_info_is_imported(PredInfo0) ->
+ Status = opt_imported
+ ;
+ pred_info_import_status(PredInfo0, Status)
+ ),
+
+ pred_info_module(PredInfo0, ModuleName),
+ pred_info_get_aditi_owner(PredInfo0, Owner),
+ pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc),
+ pred_info_init(ModuleName, SpecName, Arity, TVarSet,
+ ExistQVars, Types, true, Context, Clauses,
+ Status, Markers, none, PredOrFunc,
+ ClassContext, Proofs, Owner, NewPredInfo0),
+ pred_info_set_procedures(NewPredInfo0,
+ Procs, NewPredInfo),
+ module_info_get_predicate_table(ModuleInfo2, PredTable0),
+ predicate_table_insert(PredTable0, NewPredInfo,
+ must_be_qualified, NewPredId, PredTable),
+ module_info_set_predicate_table(ModuleInfo2,
+ PredTable, ModuleInfo3),
+
+ %
+ % Record the type specialisation in the module_info.
+ %
+ module_info_type_spec_info(ModuleInfo3, TypeSpecInfo0),
+ TypeSpecInfo0 = type_spec_info(ProcsToSpec0,
+ ForceVersions0, SpecMap0, PragmaMap0),
+ list__map(lambda([ProcId::in, PredProcId::out] is det, (
+ PredProcId = proc(PredId, ProcId)
+ )), ProcIds, PredProcIds),
+ set__insert_list(ProcsToSpec0, PredProcIds, ProcsToSpec),
+ set__insert(ForceVersions0, NewPredId, ForceVersions),
+
+ ( Status = opt_imported ->
+ % For imported predicates dead_proc_elim.m needs
+ % to know that if the original predicate is used,
+ % the predicate to force the production of the
+ % specialised interface is also used.
+ multi_map__set(SpecMap0, PredId, NewPredId, SpecMap)
+ ;
+ SpecMap = SpecMap0
+ ),
+
+ multi_map__set(PragmaMap0, PredId, Pragma, PragmaMap),
+ TypeSpecInfo = type_spec_info(ProcsToSpec,
+ ForceVersions, SpecMap, PragmaMap),
+ module_info_set_type_spec_info(ModuleInfo3,
+ TypeSpecInfo, ModuleInfo)
+ ;
+ ModuleInfo = ModuleInfo2
+ }
+ ;
+ { ModuleInfo = ModuleInfo1 }
+ ).
+
+:- pred handle_pragma_type_spec_subst(prog_context, assoc_list(tvar, type),
+ tvarset, pred_info, tvarset, list(type), existq_tvars,
+ class_constraints, bool, module_info, module_info,
+ io__state, io__state).
+:- mode handle_pragma_type_spec_subst(in, in, in, in, out, out, out, out, out,
+ in, out, di, uo) is det.
+
+handle_pragma_type_spec_subst(Context, Subst, TVarSet0, PredInfo0,
+ TVarSet, Types, ExistQVars, ClassContext, SubstOk,
+ ModuleInfo0, ModuleInfo) -->
+ ( { Subst = [] } ->
+ report_empty_subst(PredInfo0, Context),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ { ExistQVars = [] },
+ { Types = [] },
+ { ClassContext = constraints([], []) },
+ { varset__init(TVarSet) },
+ { SubstOk = no }
+ ;
+ { pred_info_typevarset(PredInfo0, CalledTVarSet) },
+ { varset__create_name_var_map(TVarSet0, NameVarIndex0) },
+ { assoc_list__keys(Subst, VarsToSub) },
+ { list__filter(lambda([Var::in] is semidet, (
+ varset__lookup_name(TVarSet0, Var, VarName),
+ \+ map__contains(NameVarIndex0, VarName)
+ )), VarsToSub, UnknownVarsToSub) },
+ ( { UnknownVarsToSub = [] } ->
+ % Check that the substitution makes all types involved
+ % ground. This is not strictly necessary, but handling
+ % this case with --typeinfo-liveness is tricky (to get the
+ % order of any extra typeclass_infos right), and it probably
+ % isn't very useful. If this restriction is removed later,
+ % remember to report an error for recursive substitutions.
+ { map__init(TVarRenaming0) },
+ { assoc_list__values(Subst, SubstTypes) },
+ { list__filter(lambda([SubstType::in] is semidet, (
+ \+ term__is_ground(SubstType)
+ )), SubstTypes, NonGroundTypes) },
+
+ ( { NonGroundTypes = [] } ->
+ { get_new_tvars(VarsToSub, TVarSet0, CalledTVarSet,
+ TVarSet, NameVarIndex0, _,
+ TVarRenaming0, TVarRenaming) },
+
+ % Check that none of the existentially quantified
+ % variables were substituted.
+ { map__apply_to_list(VarsToSub, TVarRenaming,
+ RenamedVars) },
+ { pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars) },
+ { list__filter(lambda([RenamedVar::in] is semidet, (
+ list__member(RenamedVar, ExistQVars)
+ )), RenamedVars, SubExistQVars) },
+ ( { SubExistQVars = [] } ->
+ {
+ map__apply_to_list(VarsToSub, TVarRenaming,
+ RenamedVarsToSub),
+ map__init(TypeSubst0),
+ assoc_list__from_corresponding_lists(RenamedVarsToSub,
+ SubstTypes, SubAL),
+ list__foldl(
+ lambda([(TVar - Type)::in, TSubst0::in,
+ TSubst::out] is det, (
+ map__set(TSubst0, TVar, Type, TSubst)
+ )), SubAL, TypeSubst0, TypeSubst),
+
+ % Apply the substitution.
+ pred_info_arg_types(PredInfo0, Types0),
+ pred_info_get_class_context(PredInfo0,
+ ClassContext0),
+ term__apply_rec_substitution_to_list(Types0,
+ TypeSubst, Types),
+ apply_rec_subst_to_constraints(TypeSubst,
+ ClassContext0, ClassContext),
+ SubstOk = yes,
+ ModuleInfo = ModuleInfo0
+ }
+ ;
+ report_subst_existq_tvars(PredInfo0, Context,
+ SubExistQVars),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ { Types = [] },
+ { ClassContext = constraints([], []) },
+ { SubstOk = no }
+ )
+ ;
+ report_non_ground_subst(PredInfo0, Context),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ { ExistQVars = [] },
+ { Types = [] },
+ { ClassContext = constraints([], []) },
+ { varset__init(TVarSet) },
+ { SubstOk = no }
+ )
+ ;
+ report_unknown_vars_to_subst(PredInfo0, Context,
+ TVarSet0, UnknownVarsToSub),
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ { ExistQVars = [] },
+ { Types = [] },
+ { ClassContext = constraints([], []) },
+ { varset__init(TVarSet) },
+ { SubstOk = no }
+ )
+ ).
+
+:- pred report_empty_subst(pred_info, prog_context,
+ io__state, io__state).
+:- mode report_empty_subst(in, in, di, uo) is det.
+
+report_empty_subst(PredInfo0, Context) -->
+ report_pragma_type_spec(PredInfo0, Context),
+ io__write_string(" error: empty substitution.\n").
+
+:- pred report_subst_existq_tvars(pred_info, prog_context,
+ list(tvar), io__state, io__state).
+:- mode report_subst_existq_tvars(in, in, in, di, uo) is det.
+
+report_subst_existq_tvars(PredInfo0, Context, SubExistQVars) -->
+ report_pragma_type_spec(PredInfo0, Context),
+ prog_out__write_context(Context),
+ io__write_string(" error: the substitution includes the existentially\n"),
+ prog_out__write_context(Context),
+ io__write_string(" quantified type "),
+ { pred_info_typevarset(PredInfo0, TVarSet) },
+ report_variables(SubExistQVars, TVarSet),
+ io__write_string(".\n").
+
+:- pred report_non_ground_subst(pred_info, prog_context,
+ io__state, io__state).
+:- mode report_non_ground_subst(in, in, di, uo) is det.
+
+report_non_ground_subst(PredInfo0, Context) -->
+ report_pragma_type_spec(PredInfo0, Context),
+ io__write_string(" error: the substitution does not make the\n"),
+ io__nl,
+ prog_out__write_context(Context),
+ io__write_string(" substituted types ground.\n").
+
+:- pred report_unknown_vars_to_subst(pred_info, prog_context, tvarset,
+ list(tvar), io__state, io__state).
+:- mode report_unknown_vars_to_subst(in, in, in, in, di, uo) is det.
+
+report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, RecursiveVars) -->
+ report_pragma_type_spec(PredInfo0, Context),
+ prog_out__write_context(Context),
+ io__write_string(" error: "),
+ report_variables(RecursiveVars, TVarSet),
+ ( { RecursiveVars = [_] } ->
+ io__write_string(" does not ")
+ ;
+ io__write_string(" do not ")
+ ),
+ io__write_string(" occur in the pred declaration.\n").
+
+:- pred report_pragma_type_spec(pred_info, term__context,
+ io__state, io__state).
+:- mode report_pragma_type_spec(in, in, di, uo) is det.
+
+report_pragma_type_spec(PredInfo0, Context) -->
+ { pred_info_module(PredInfo0, Module) },
+ { pred_info_name(PredInfo0, Name) },
+ { pred_info_arity(PredInfo0, Arity) },
+ { pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc) },
+ prog_out__write_context(Context),
+ io__write_string("In `pragma type_spec(...)' declaration for "),
+ hlds_out__write_call_id(PredOrFunc, qualified(Module, Name)/Arity),
+ io__write_string(":\n").
+
+:- pred report_variables(list(tvar), tvarset, io__state, io__state).
+:- mode report_variables(in, in, di, uo) is det.
+
+report_variables(SubExistQVars, VarSet) -->
+ ( { SubExistQVars = [_] } ->
+ io__write_string("variable `")
+ ;
+ io__write_string("variables `")
+ ),
+ mercury_output_vars(SubExistQVars, VarSet, no),
+ io__write_string("'").
+
+:- pred handle_pragma_type_spec_modes(sym_name, arity,
+ prog_context, maybe(list(mode)), list(proc_id),
+ proc_table, proc_table, bool, module_info, module_info,
+ io__state, io__state).
+:- mode handle_pragma_type_spec_modes(in, in, in, in, out, in, out,
+ out, in, out, di, uo) is det.
+
+handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes, ProcIds,
+ Procs0, Procs, ModesOk, ModuleInfo0, ModuleInfo) -->
+ ( { MaybeModes = yes(Modes) } ->
+ { map__to_assoc_list(Procs0, ExistingProcs) },
+ (
+ { get_procedure_matching_argmodes(ExistingProcs,
+ Modes, ModuleInfo0, ProcId) }
+ ->
+ { map__lookup(Procs0, ProcId, ProcInfo) },
+ { map__init(Procs1) },
+ { hlds_pred__initial_proc_id(NewProcId) },
+ { map__det_insert(Procs1, NewProcId,
+ ProcInfo, Procs) },
+ { ProcIds = [ProcId] },
+ { ModesOk = yes },
+ { ModuleInfo = ModuleInfo0 }
+ ;
+ { ProcIds = [] },
+ { Procs = Procs0 },
+ { module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+ undefined_mode_error(SymName, Arity, Context,
+ "`:- pragma type_spec(...)' declaration"),
+ { ModesOk = no }
+ )
+ ;
+ { Procs = Procs0 },
+ { map__keys(Procs, ProcIds) },
+ { ModesOk = yes },
+ { ModuleInfo = ModuleInfo0 }
).
%-----------------------------------------------------------------------------%
More information about the developers
mailing list