mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 09:53:36 +00:00
18817d62d0
Class and instance definitions both contain lists of methods,
predicates and/or functions, that each have one or more procedures.
Until now, we represented the methods in class and instance definitions
as lists of nothing more than pred_proc_ids. This fact complicated
several operations,
- partly because there was no simple way to tell which procedures
were part of the same predicate or function, and
- partly because the order of the list is important (we identify
each method procedure in our equivalent of vtables with a number,
which is simply the procedure's position in this list), but there was
absolutely no information about recorded about this.
This diff therefore replaces the lists of pred_proc_ids with lists of
method_infos. Each method_info contains
- the method procedure number, i.e. the vtable index,
- the pred_or_func, sym_name and user arity of the predicate or function
that the method procedure is a part of, to make it simple to test
whether two method_infos represent different modes of the same predicate
or function, or not,
- the original pred_proc_id of the method procedure, which never changes,
and
- the current pred_proc_id, which program transformations *can* change.
compiler/hlds_class.m:
Make the change above in the representations of class and instance
definitions.
Put the fields of both types into a better order, by putting
related fields next to each other.
Put a notag wrapper around method procedure numbers to prevent
accidentally mixing them up with plain integers.
Add some utility functions.
compiler/prog_data.m:
Replace three fields containing pred_or_func, sym_name and arity
in the parse tree representation of instance methods with just one,
which contains all three pieces of info. This makes it easier to operate
on them as a unit.
Change the representation of methods defined by clauses from a list
of clauses to a cord of clauses, since this supports constant-time
append.
compiler/hlds_goal.m:
Switch from plain ints to the new notag representation of method
procedure numbers in method call goals.
compiler/add_class.m:
Simplify the code for adding new classes to the HLDS.
Give some predicates better names.
compiler/check_typeclass.m:
Significantly simplify the code for that generates the pred_infos and
proc_infos implementing all the methods of an instances definition,
and construct lists of method_infos instead of lists of pred_proc_ids.
Give some predicates better names.
Some error messages about problems in instance definitions started with
In instance declaration for class/arity:
while others started with
In instance declaration for class(module_a.foo, module_b.bar):
Replace both with
In instance declaration for class(foo, bar):
because it contains more useful information than the first, and less
non-useful information than the second. Improve the wording of some
error messages.
Factor out some common code.
compiler/prog_mode.m:
compiler/prog_type.m:
compiler/prog_util.m:
Generalize the existing predicates for stripping "builtin.m" module
qualifiers from sym_names, cons_ids, insts, types and modes
to allow also the stripping of *all* module qualifiers. This capability
is now used when we print an instance's type vector as a context
for diagnostics about problems inside instance definitions.
compiler/add_pred.m:
Add a mechanism for returning the pred_id of a newly created pred_info,
whether or not it was declared using a predmode declaration. This
capability is now needed by add_class.m.
Move the code creating an error message into its own function, and export
that function for add_class.m.
compiler/polymorphism_type_info.m:
Fix some comment rot.
compiler/base_typeclass_info.m:
compiler/call_gen.m:
compiler/dead_proc_elim.m:
compiler/deep_profiling.m:
compiler/direct_arg_in_out.m:
compiler/error_msg_inst.m:
compiler/float_regs.m:
compiler/get_dependencies.m:
compiler/higher_order.m:
compiler/hlds_error_util.m:
compiler/hlds_out_goal.m:
compiler/hlds_out_typeclass_table.m:
compiler/instance_method_clauses.m:
compiler/intermod.m:
compiler/make_hlds_error.m:
compiler/ml_call_gen.m:
compiler/mode_errors.m:
compiler/modes.m:
compiler/module_qual.qualify_items.m:
compiler/old_type_constraints.m:
compiler/parse_class.m:
compiler/parse_tree_out.m:
compiler/parse_tree_out_inst.m:
compiler/polymorphism_post_copy.m:
compiler/polymorphism_type_class_info.m:
compiler/prog_item.m:
compiler/prog_rep.m:
compiler/recompilation.usage.m:
compiler/state_var.m:
compiler/type_class_info.m:
compiler/typecheck_debug.m:
compiler/typecheck_error_type_assign.m:
compiler/typecheck_errors.m:
compiler/typecheck_msgs.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
Conform to the changes above.
tests/invalid/bug476.err_exp:
tests/invalid/tc_err1.err_exp:
tests/invalid/tc_err2.err_exp:
tests/invalid/typeclass_bogus_method.err_exp:
tests/invalid/typeclass_missing_mode.err_exp:
tests/invalid/typeclass_missing_mode_2.err_exp:
tests/invalid/typeclass_mode.err_exp:
tests/invalid/typeclass_mode_2.err_exp:
tests/invalid/typeclass_mode_3.err_exp:
tests/invalid/typeclass_mode_4.err_exp:
tests/invalid/typeclass_test_10.err_exp:
tests/invalid/typeclass_test_3.err_exp:
tests/invalid/typeclass_test_4.err_exp:
tests/invalid/typeclass_test_5.err_exp:
tests/invalid/typeclass_test_9.err_exp:
Expect the updated wording of some error messages.
3655 lines
150 KiB
Mathematica
3655 lines
150 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2012 The University of Melbourne.
|
|
% Copyright (C) 2015 The Mercury team.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: higher_order.m.
|
|
% Main author: stayl.
|
|
%
|
|
% Specializes calls to higher order or polymorphic predicates where the value
|
|
% of one or more higher order, type_info or typeclass_info arguments are known.
|
|
%
|
|
% Since this creates a new copy of the called procedure, I have limited the
|
|
% specialization to cases where the called procedure's goal contains less than
|
|
% 20 calls and unifications. For predicates above this size, the overhead of
|
|
% the higher order call becomes less significant while the increase in code
|
|
% size becomes significant. The limit can be changed using
|
|
% `--higher-order-size-limit'.
|
|
%
|
|
% If a specialization creates new opportunities for specialization, we will
|
|
% continue iterating the specialization process until we find no further
|
|
% opportunities, i.e. until we reach a fixpoint.
|
|
%
|
|
% The specialized version of a predicate 'foo' is named 'foo.ho<n>',
|
|
% where n is a number that uniquely identifies this specialized version.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module transform_hlds.higher_order.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_module.
|
|
|
|
:- import_module io.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred specialize_higher_order(module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.
|
|
:- import_module check_hlds.mode_test.
|
|
:- import_module check_hlds.mode_util.
|
|
:- import_module check_hlds.polymorphism_type_info.
|
|
:- import_module check_hlds.recompute_instmap_deltas.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.add_special_pred.
|
|
:- import_module hlds.const_struct.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.instmap.
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.passes_aux.
|
|
:- import_module hlds.pred_name.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.quantification.
|
|
:- import_module hlds.special_pred.
|
|
:- import_module hlds.status.
|
|
:- import_module libs.
|
|
:- import_module libs.file_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.optimization_options.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.builtin_modules.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.builtin_lib_types.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_mode.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.set_of_var.
|
|
:- import_module parse_tree.var_table.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bool.
|
|
:- import_module counter.
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module string.
|
|
:- import_module term_context.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
specialize_higher_order(!ModuleInfo, !IO) :-
|
|
% Iterate collecting requests and process them until there are no more
|
|
% requests remaining.
|
|
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.get_opt_tuple(Globals, OptTuple),
|
|
HigherOrder = OptTuple ^ ot_opt_higher_order,
|
|
TypeSpec = OptTuple ^ ot_spec_types,
|
|
UserTypeSpec = OptTuple ^ ot_spec_types_user_guided,
|
|
SizeLimit = OptTuple ^ ot_higher_order_size_limit,
|
|
ArgLimit = OptTuple ^ ot_higher_order_arg_limit,
|
|
Params =
|
|
ho_params(HigherOrder, TypeSpec, UserTypeSpec, SizeLimit, ArgLimit),
|
|
map.init(NewPredMap0),
|
|
map.init(GoalSizes0),
|
|
set.init(Requests0),
|
|
map.init(VersionInfo0),
|
|
some [!GlobalInfo] (
|
|
!:GlobalInfo = higher_order_global_info(Requests0, NewPredMap0,
|
|
VersionInfo0, !.ModuleInfo, GoalSizes0, Params, counter.init(1)),
|
|
|
|
module_info_get_valid_pred_ids(!.ModuleInfo, ValidPredIds),
|
|
module_info_get_type_spec_info(!.ModuleInfo, TypeSpecInfo),
|
|
TypeSpecInfo = type_spec_info(_, UserSpecPredIdSet, _, _),
|
|
|
|
globals.lookup_bool_option(Globals, debug_higher_order_specialization,
|
|
DebugSpec),
|
|
(
|
|
DebugSpec = no,
|
|
MaybeProgressStream = no
|
|
;
|
|
DebugSpec = yes,
|
|
get_progress_output_stream(!.ModuleInfo, ProgressStream, !IO),
|
|
MaybeProgressStream = yes(ProgressStream)
|
|
),
|
|
|
|
% Make sure the user requested specializations are processed first,
|
|
% since we don't want to create more versions if one of these matches.
|
|
% We need to process these even if specialization is not being
|
|
% performed, in case any of the specialized versions are called
|
|
% from other modules.
|
|
|
|
set.to_sorted_list(UserSpecPredIdSet, UserSpecPredIds),
|
|
(
|
|
UserSpecPredIds = [],
|
|
NonUserSpecPredIds = ValidPredIds
|
|
;
|
|
UserSpecPredIds = [_ | _],
|
|
set.list_to_set(ValidPredIds, ValidPredIdSet),
|
|
set.difference(ValidPredIdSet, UserSpecPredIdSet,
|
|
NonUserSpecPredIdSet),
|
|
set.to_sorted_list(NonUserSpecPredIdSet, NonUserSpecPredIds),
|
|
|
|
!GlobalInfo ^ hogi_params ^ param_do_user_type_spec
|
|
:= spec_types_user_guided,
|
|
list.foldl(get_specialization_requests, UserSpecPredIds,
|
|
!GlobalInfo),
|
|
process_ho_spec_requests(MaybeProgressStream, !GlobalInfo, !IO)
|
|
),
|
|
|
|
( if
|
|
( HigherOrder = opt_higher_order
|
|
; TypeSpec = spec_types
|
|
; UserTypeSpec = spec_types_user_guided
|
|
)
|
|
then
|
|
% Process all other specializations until no more requests
|
|
% are generated.
|
|
list.foldl(get_specialization_requests, NonUserSpecPredIds,
|
|
!GlobalInfo),
|
|
recursively_process_ho_spec_requests(MaybeProgressStream,
|
|
!GlobalInfo, !IO)
|
|
else
|
|
true
|
|
),
|
|
|
|
% 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, UserSpecPredIds,
|
|
!.GlobalInfo ^ hogi_module_info, !:ModuleInfo)
|
|
).
|
|
|
|
% Process one lot of requests, returning requests for any
|
|
% new specializations made possible by the first lot.
|
|
%
|
|
:- pred process_ho_spec_requests(maybe(io.text_output_stream)::in,
|
|
higher_order_global_info::in, higher_order_global_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
process_ho_spec_requests(MaybeProgressStream, !GlobalInfo, !IO) :-
|
|
Requests0 = set.to_sorted_list(!.GlobalInfo ^ hogi_requests),
|
|
!GlobalInfo ^ hogi_requests := set.init,
|
|
list.foldl3(filter_request(MaybeProgressStream, !.GlobalInfo), Requests0,
|
|
[], Requests, [], LoopRequests, !IO),
|
|
(
|
|
Requests = []
|
|
;
|
|
Requests = [_ | _],
|
|
some [!PredProcsToFix] (
|
|
set.init(!:PredProcsToFix),
|
|
maybe_create_new_ho_spec_preds(MaybeProgressStream, Requests,
|
|
[], NewPredList, !PredProcsToFix, !GlobalInfo, !IO),
|
|
list.foldl(check_loop_request(!.GlobalInfo), LoopRequests,
|
|
!PredProcsToFix),
|
|
set.to_sorted_list(!.PredProcsToFix, PredProcs)
|
|
),
|
|
ho_fixup_specialized_versions(NewPredList, !GlobalInfo),
|
|
ho_fixup_preds(PredProcs, !GlobalInfo),
|
|
(
|
|
NewPredList = [_ | _],
|
|
% The dependencies may have changed, so the dependency graph
|
|
% needs to rebuilt for inlining to work properly.
|
|
ModuleInfo0 = !.GlobalInfo ^ hogi_module_info,
|
|
module_info_clobber_dependency_info(ModuleInfo0, ModuleInfo),
|
|
!GlobalInfo ^ hogi_module_info := ModuleInfo
|
|
;
|
|
NewPredList = []
|
|
)
|
|
).
|
|
|
|
% Process requests until there are no new requests to process.
|
|
%
|
|
:- pred recursively_process_ho_spec_requests(maybe(io.text_output_stream)::in,
|
|
higher_order_global_info::in, higher_order_global_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
recursively_process_ho_spec_requests(MaybeProgressStream, !GlobalInfo, !IO) :-
|
|
( if set.is_empty(!.GlobalInfo ^ hogi_requests) then
|
|
true
|
|
else
|
|
process_ho_spec_requests(MaybeProgressStream, !GlobalInfo, !IO),
|
|
recursively_process_ho_spec_requests(MaybeProgressStream,
|
|
!GlobalInfo, !IO)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type higher_order_global_info
|
|
---> higher_order_global_info(
|
|
% Requested versions.
|
|
hogi_requests :: set(ho_request),
|
|
|
|
% Specialized versions for each predicate
|
|
% not changed by ho_traverse_proc_body.
|
|
hogi_new_pred_map :: new_pred_map,
|
|
|
|
% Extra information about each specialized version.
|
|
hogi_version_info :: map(pred_proc_id, version_info),
|
|
|
|
hogi_module_info :: module_info,
|
|
hogi_goal_sizes :: goal_sizes,
|
|
hogi_params :: ho_params,
|
|
|
|
% Number identifying a specialized version.
|
|
hogi_next_id :: counter
|
|
).
|
|
|
|
% Used while traversing goals.
|
|
%
|
|
:- type higher_order_info
|
|
---> higher_order_info(
|
|
hoi_global_info :: higher_order_global_info,
|
|
|
|
% Higher order variables with unique known values.
|
|
hoi_known_var_map :: known_var_map,
|
|
|
|
% The pred_proc_id, pred_info and proc_info of the procedure
|
|
% whose body is being traversed.
|
|
hoi_pred_proc_id :: pred_proc_id,
|
|
hoi_pred_info :: pred_info,
|
|
hoi_proc_info :: proc_info,
|
|
|
|
hoi_changed :: ho_changed
|
|
).
|
|
|
|
:- type ho_request
|
|
---> ho_request(
|
|
% Calling predicate.
|
|
rq_caller :: pred_proc_id,
|
|
|
|
% Called predicate.
|
|
rq_callee :: pred_proc_id,
|
|
|
|
% The call's arguments, and their types.
|
|
rq_args :: assoc_list(prog_var, mer_type),
|
|
|
|
% Type variables for which extra type-infos must be passed
|
|
% from the caller if --typeinfo-liveness is set.
|
|
rq_tvars :: list(tvar),
|
|
|
|
% Argument types in caller, other than the ones in rq_args.
|
|
rq_ho_args :: list(higher_order_arg),
|
|
|
|
% Caller's typevarset.
|
|
rq_caller_tvarset :: tvarset,
|
|
|
|
% Should the interface of the specialized procedure
|
|
% use typeinfo liveness?
|
|
% XXX Unfortunately, this field is not doing its job.
|
|
% First, it is only ever set to "yes", so it is redundant.
|
|
% Second, its value is only ever used for one thing, which
|
|
% is to set the value of the np_typeinfo_liveness field
|
|
% in the new_pred type, which is itself never used.
|
|
rq_typeinfo_liveness :: bool,
|
|
|
|
% Is this a user-requested specialization?
|
|
rq_request_kind :: ho_request_kind,
|
|
|
|
% Context of the call which caused the request to be generated.
|
|
rq_call_context :: prog_context
|
|
).
|
|
|
|
:- type ho_request_kind
|
|
---> non_user_type_spec
|
|
; user_type_spec.
|
|
|
|
% Stores cons_id, index in argument vector, number of curried arguments
|
|
% of a higher order argument, higher-order curried arguments with known
|
|
% values. For cons_ids other than pred_const and `type_info', the arguments
|
|
% must be constants.
|
|
%
|
|
:- type higher_order_arg
|
|
---> higher_order_arg(
|
|
hoa_cons_id :: cons_id,
|
|
|
|
% Index in argument vector.
|
|
hoa_index :: int,
|
|
|
|
% Number of curried args.
|
|
hoa_num_curried_args :: int,
|
|
|
|
% Curried arguments in caller.
|
|
hoa_curry_arg_in_caller :: list(prog_var),
|
|
|
|
% Curried argument types in caller.
|
|
hoa_curry_type_in_caller :: list(mer_type),
|
|
|
|
% Types associated with type_infos and constraints associated
|
|
% with typeclass_infos in the arguments.
|
|
hoa_curry_rtti_type :: list(rtti_var_info),
|
|
|
|
% Higher-order curried arguments with known values.
|
|
hoa_known_curry_args :: list(higher_order_arg),
|
|
|
|
% Is this higher_order_arg a constant?
|
|
hoa_is_constant :: bool
|
|
).
|
|
|
|
% Stores the size of each predicate's goal used in the heuristic
|
|
% to decide which preds are specialized.
|
|
%
|
|
:- type goal_sizes == map(pred_id, int).
|
|
|
|
% Used to hold the value of known higher order variables.
|
|
% If a variable is not in the map, it does not have a unique known value.
|
|
%
|
|
:- type known_var_map == map(prog_var, known_const).
|
|
|
|
:- type new_pred_map == map(pred_proc_id, set(new_pred)).
|
|
|
|
% The list of vars is a list of the curried arguments, which must
|
|
% be explicitly passed to the specialized predicate.
|
|
% For cons_ids other than pred_const and `type_info', the arguments
|
|
% must be constants. For pred_consts and type_infos, non-constant
|
|
% arguments are passed through to any specialised version.
|
|
%
|
|
:- type known_const
|
|
---> known_const(cons_id, list(prog_var)).
|
|
|
|
:- type ho_params
|
|
---> ho_params(
|
|
% Propagate higher-order constants.
|
|
param_do_higher_order_spec :: maybe_opt_higher_order,
|
|
|
|
% Propagate type-info constants.
|
|
param_do_type_spec :: maybe_spec_types,
|
|
|
|
% User-guided type specialization.
|
|
param_do_user_type_spec :: maybe_spec_types_user_guided,
|
|
|
|
% Size limit on requested version.
|
|
param_size_limit :: int,
|
|
|
|
% The maximum size of the higher order arguments
|
|
% of a specialized version.
|
|
param_arg_limit :: int
|
|
).
|
|
|
|
:- type version_info
|
|
---> version_info(
|
|
% The procedure from the original program from which
|
|
% this version was created.
|
|
pred_proc_id,
|
|
|
|
% Depth of the higher_order_args for this version.
|
|
int,
|
|
|
|
% Higher-order or constant input variables for a
|
|
% specialised version.
|
|
known_var_map,
|
|
|
|
% The chain of specialized versions which caused this version
|
|
% to be created. For each element in the list with the same
|
|
% pred_proc_id, the depth must decrease. This ensures that
|
|
% the specialization process must terminate.
|
|
list(parent_version_info)
|
|
).
|
|
|
|
:- type parent_version_info
|
|
---> parent_version_info(
|
|
% The procedure from the original program from which
|
|
% this parent was created.
|
|
pred_proc_id,
|
|
|
|
% Depth of the higher_order_args for this version.
|
|
int
|
|
).
|
|
|
|
:- type new_pred
|
|
---> new_pred(
|
|
% version pred_proc_id
|
|
np_version_ppid :: pred_proc_id,
|
|
|
|
% old pred_proc_id
|
|
np_old_ppid :: pred_proc_id,
|
|
|
|
% requesting caller
|
|
np_req_ppid :: pred_proc_id,
|
|
|
|
% name
|
|
np_name :: sym_name,
|
|
|
|
% specialized args
|
|
np_spec_args :: list(higher_order_arg),
|
|
|
|
% Unspecialised argument vars in caller, and their types.
|
|
np_unspec_actuals :: assoc_list(prog_var, mer_type),
|
|
|
|
% Extra typeinfo tvars in caller.
|
|
np_extra_act_ti_vars :: list(tvar),
|
|
|
|
% Caller's typevarset.
|
|
np_call_tvarset :: tvarset,
|
|
|
|
% Does the interface of the specialized version use type-info
|
|
% liveness?
|
|
% XXX Unfortunately, this field is not doing its job;
|
|
% its value is never used for anything.
|
|
np_typeinfo_liveness :: bool,
|
|
|
|
% Is this a user-specified type specialization?
|
|
np_is_user_spec :: ho_request_kind
|
|
).
|
|
|
|
% Returned by ho_traverse_proc_body.
|
|
%
|
|
:- type ho_changed
|
|
---> hoc_changed % Need to requantify goal + check other procs
|
|
; hoc_request % Need to check other procs
|
|
; hoc_unchanged. % Do nothing more for this predicate
|
|
|
|
:- func get_np_version_ppid(new_pred) = pred_proc_id.
|
|
|
|
get_np_version_ppid(NewPred) = NewPred ^ np_version_ppid.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred get_specialization_requests(pred_id::in,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
get_specialization_requests(PredId, !GlobalInfo) :-
|
|
ModuleInfo0 = !.GlobalInfo ^ hogi_module_info,
|
|
module_info_pred_info(ModuleInfo0, PredId, PredInfo0),
|
|
NonImportedProcs = pred_info_valid_non_imported_procids(PredInfo0),
|
|
(
|
|
NonImportedProcs = []
|
|
;
|
|
NonImportedProcs = [ProcId | _],
|
|
list.foldl(ho_traverse_proc(need_not_recompute, PredId),
|
|
NonImportedProcs, !GlobalInfo),
|
|
|
|
ModuleInfo1 = !.GlobalInfo ^ hogi_module_info,
|
|
module_info_proc_info(ModuleInfo1, PredId, ProcId, ProcInfo),
|
|
proc_info_get_goal(ProcInfo, Goal),
|
|
goal_size(Goal, GoalSize),
|
|
GoalSizes1 = !.GlobalInfo ^ hogi_goal_sizes,
|
|
map.set(PredId, GoalSize, GoalSizes1, GoalSizes),
|
|
!GlobalInfo ^ hogi_goal_sizes := GoalSizes
|
|
).
|
|
|
|
% This is called when the first procedure of a predicate was changed.
|
|
% It fixes up all the other procedures, ignoring the goal_size and requests
|
|
% that come out, since that information has already been collected.
|
|
%
|
|
:- pred ho_traverse_proc(must_recompute::in, pred_id::in, proc_id::in,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
ho_traverse_proc(MustRecompute, PredId, ProcId, !GlobalInfo) :-
|
|
map.init(KnownVarMap0),
|
|
module_info_pred_proc_info(!.GlobalInfo ^ hogi_module_info,
|
|
PredId, ProcId, PredInfo0, ProcInfo0),
|
|
Info0 = higher_order_info(!.GlobalInfo, KnownVarMap0, proc(PredId, ProcId),
|
|
PredInfo0, ProcInfo0, hoc_unchanged),
|
|
ho_traverse_proc_body(MustRecompute, Info0, Info),
|
|
Info = higher_order_info(!:GlobalInfo, _, _, PredInfo, ProcInfo, _),
|
|
ModuleInfo0 = !.GlobalInfo ^ hogi_module_info,
|
|
module_info_set_pred_proc_info(PredId, ProcId, PredInfo, ProcInfo,
|
|
ModuleInfo0, ModuleInfo),
|
|
!GlobalInfo ^ hogi_module_info := ModuleInfo.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Goal traversal
|
|
%
|
|
|
|
:- pred ho_fixup_proc_info(must_recompute::in, hlds_goal::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_fixup_proc_info(MustRecompute, !.Goal, !Info) :-
|
|
( if
|
|
( !.Info ^ hoi_changed = hoc_changed
|
|
; MustRecompute = must_recompute
|
|
)
|
|
then
|
|
% XXX The code whose effects we are now fixing up can eliminate
|
|
% some variables from the code of the procedure. Some of those
|
|
% variables appear in the RTTI varmaps, yet we do not delete them
|
|
% from there. This is a bug.
|
|
some [!ModuleInfo, !ProcInfo] (
|
|
!:ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
!:ProcInfo = !.Info ^ hoi_proc_info,
|
|
proc_info_set_goal(!.Goal, !ProcInfo),
|
|
requantify_proc_general(ord_nl_no_lambda, !ProcInfo),
|
|
proc_info_get_goal(!.ProcInfo, !:Goal),
|
|
proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InstMap),
|
|
proc_info_get_var_table(!.ProcInfo, VarTable),
|
|
proc_info_get_inst_varset(!.ProcInfo, InstVarSet),
|
|
recompute_instmap_delta(no_recomp_atomics, VarTable, InstVarSet,
|
|
InstMap, !Goal, !ModuleInfo),
|
|
proc_info_set_goal(!.Goal, !ProcInfo),
|
|
!Info ^ hoi_proc_info := !.ProcInfo,
|
|
!Info ^ hoi_global_info ^ hogi_module_info := !.ModuleInfo
|
|
)
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred ho_traverse_proc_body(must_recompute::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_proc_body(MustRecompute, !Info) :-
|
|
% Lookup the initial known bindings of the variables if this procedure
|
|
% is a specialised version.
|
|
VersionInfoMap = !.Info ^ hoi_global_info ^ hogi_version_info,
|
|
( if
|
|
map.search(VersionInfoMap, !.Info ^ hoi_pred_proc_id, VersionInfo),
|
|
VersionInfo = version_info(_, _, KnownVarMap, _)
|
|
then
|
|
!Info ^ hoi_known_var_map := KnownVarMap
|
|
else
|
|
true
|
|
),
|
|
proc_info_get_goal(!.Info ^ hoi_proc_info, Goal0),
|
|
ho_traverse_goal(Goal0, Goal, !Info),
|
|
ho_fixup_proc_info(MustRecompute, Goal, !Info).
|
|
|
|
% Traverse the goal collecting higher order variables for which the value
|
|
% is known, specialize calls, and add specialization requests to the
|
|
% request_info structure.
|
|
%
|
|
:- pred ho_traverse_goal(hlds_goal::in, hlds_goal::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_goal(Goal0, Goal, !Info) :-
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
(
|
|
GoalExpr0 = conj(ConjType, Goals0),
|
|
(
|
|
ConjType = plain_conj,
|
|
list.map_foldl(ho_traverse_goal, Goals0, Goals, !Info)
|
|
;
|
|
ConjType = parallel_conj,
|
|
ho_traverse_parallel_conj(Goals0, Goals, !Info)
|
|
),
|
|
GoalExpr = conj(ConjType, Goals),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = disj(Goals0),
|
|
ho_traverse_disj(Goals0, Goals, !Info),
|
|
GoalExpr = disj(Goals),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = switch(Var, CanFail, Cases0),
|
|
% A switch is treated as a disjunction.
|
|
ho_traverse_cases(Cases0, Cases, !Info),
|
|
GoalExpr = switch(Var, CanFail, Cases),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = generic_call(GenericCall, Args, _, _, _),
|
|
% Check whether this call could be specialized.
|
|
(
|
|
GenericCall = higher_order(Var, _, _, _),
|
|
maybe_specialize_higher_order_call(Var, Args, Goal0, Goal, !Info)
|
|
;
|
|
GenericCall = class_method(Var, Method, _, _),
|
|
maybe_specialize_method_call(Var, Method, Args, Goal0, Goal, !Info)
|
|
;
|
|
( GenericCall = event_call(_)
|
|
; GenericCall = cast(_)
|
|
),
|
|
Goal = Goal0
|
|
)
|
|
;
|
|
GoalExpr0 = plain_call(_, _, _, _, _, _),
|
|
% Check whether this call can be specialized.
|
|
% XXX Due to the absence of alias tracking, passing Goal0 instead
|
|
% of Goal1 to maybe_specialize_call would result in a mode error.
|
|
Goal1 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
maybe_specialize_call(Goal1, Goal, !Info)
|
|
;
|
|
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
|
|
% If-then-elses are handled as disjunctions.
|
|
get_pre_branch_info(!.Info, PreInfo),
|
|
ho_traverse_goal(Cond0, Cond, !Info),
|
|
ho_traverse_goal(Then0, Then, !Info),
|
|
get_post_branch_info_for_goal(!.Info, Then, PostThenInfo),
|
|
set_pre_branch_info(PreInfo, !Info),
|
|
ho_traverse_goal(Else0, Else, !Info),
|
|
get_post_branch_info_for_goal(!.Info, Else, PostElseInfo),
|
|
merge_post_branch_infos(PostThenInfo, PostElseInfo, PostInfo),
|
|
set_post_branch_info(PostInfo, !Info),
|
|
GoalExpr = if_then_else(Vars, Cond, Then, Else),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = negation(SubGoal0),
|
|
ho_traverse_goal(SubGoal0, SubGoal, !Info),
|
|
GoalExpr = negation(SubGoal),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = scope(Reason, SubGoal0),
|
|
( if
|
|
Reason = from_ground_term(_, FGT),
|
|
( FGT = from_ground_term_construct
|
|
; FGT = from_ground_term_deconstruct
|
|
)
|
|
then
|
|
Goal = Goal0
|
|
else
|
|
ho_traverse_goal(SubGoal0, SubGoal, !Info),
|
|
GoalExpr = scope(Reason, SubGoal),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
)
|
|
;
|
|
GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _),
|
|
Goal = Goal0
|
|
;
|
|
GoalExpr0 = unify(_, _, _, Unification0, _),
|
|
( if
|
|
Unification0 = construct(_, closure_cons(_, _), _, _, _, _, _)
|
|
then
|
|
maybe_specialize_pred_const(Goal0, Goal, !Info)
|
|
else
|
|
Goal = Goal0
|
|
),
|
|
( if Goal = hlds_goal(unify(_, _, _, Unification, _), _) then
|
|
check_unify(Unification, !Info)
|
|
else
|
|
true
|
|
)
|
|
;
|
|
GoalExpr0 = shorthand(_),
|
|
% These should have been expanded out by now.
|
|
unexpected($pred, "shorthand")
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% To process a parallel conjunction, we process each conjunct with the
|
|
% specialization information before the conjunct, then merge the
|
|
% results to give the specialization information after the conjunction.
|
|
%
|
|
:- pred ho_traverse_parallel_conj(hlds_goals::in, hlds_goals::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_parallel_conj(Goals0, Goals, !Info) :-
|
|
(
|
|
Goals0 = [],
|
|
unexpected($pred, "empty list")
|
|
;
|
|
Goals0 = [_ | _],
|
|
get_pre_branch_info(!.Info, PreInfo),
|
|
ho_traverse_parallel_conj_loop(PreInfo, Goals0, Goals,
|
|
[], PostInfos, !Info),
|
|
merge_post_branch_infos_into_one(PostInfos, PostInfo),
|
|
set_post_branch_info(PostInfo, !Info)
|
|
).
|
|
|
|
:- pred ho_traverse_parallel_conj_loop(pre_branch_info::in,
|
|
hlds_goals::in, hlds_goals::out,
|
|
list(post_branch_info)::in, list(post_branch_info)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_parallel_conj_loop(_, [], [], !PostInfos, !Info).
|
|
ho_traverse_parallel_conj_loop(PreInfo, [Goal0 | Goals0], [Goal | Goals],
|
|
!PostInfos, !Info) :-
|
|
set_pre_branch_info(PreInfo, !Info),
|
|
ho_traverse_goal(Goal0, Goal, !Info),
|
|
get_post_branch_info_for_goal(!.Info, Goal, GoalPostInfo),
|
|
!:PostInfos = [GoalPostInfo | !.PostInfos],
|
|
ho_traverse_parallel_conj_loop(PreInfo, Goals0, Goals, !PostInfos, !Info).
|
|
|
|
% To process a disjunction, we process each disjunct with the
|
|
% specialization information before the goal, then merge the
|
|
% results to give the specialization information after the disjunction.
|
|
%
|
|
:- pred ho_traverse_disj(list(hlds_goal)::in, list(hlds_goal)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_disj(Goals0, Goals, !Info) :-
|
|
% We handle empty lists separately because merge_post_branch_infos_into_one
|
|
% works only on nonempty lists.
|
|
(
|
|
Goals0 = [],
|
|
Goals = []
|
|
;
|
|
Goals0 = [_ | _],
|
|
get_pre_branch_info(!.Info, PreInfo),
|
|
ho_traverse_disj_loop(PreInfo, Goals0, Goals, [], PostInfos, !Info),
|
|
merge_post_branch_infos_into_one(PostInfos, PostInfo),
|
|
set_post_branch_info(PostInfo, !Info)
|
|
).
|
|
|
|
:- pred ho_traverse_disj_loop(pre_branch_info::in,
|
|
list(hlds_goal)::in, list(hlds_goal)::out,
|
|
list(post_branch_info)::in, list(post_branch_info)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_disj_loop(_, [], [], !PostInfos, !Info).
|
|
ho_traverse_disj_loop(PreInfo, [Goal0 | Goals0], [Goal | Goals],
|
|
!PostInfos, !Info) :-
|
|
set_pre_branch_info(PreInfo, !Info),
|
|
ho_traverse_goal(Goal0, Goal, !Info),
|
|
get_post_branch_info_for_goal(!.Info, Goal, GoalPostInfo),
|
|
!:PostInfos = [GoalPostInfo | !.PostInfos],
|
|
ho_traverse_disj_loop(PreInfo, Goals0, Goals, !PostInfos, !Info).
|
|
|
|
% Switches are treated in exactly the same way as disjunctions.
|
|
%
|
|
:- pred ho_traverse_cases(list(case)::in, list(case)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_cases(Cases0, Cases, !Info) :-
|
|
% We handle empty lists separately because merge_post_branch_infos_into_one
|
|
% works only on nonempty lists.
|
|
(
|
|
Cases0 = [],
|
|
unexpected($pred, "empty list of cases")
|
|
;
|
|
Cases0 = [_ | _],
|
|
get_pre_branch_info(!.Info, PreInfo),
|
|
ho_traverse_cases_loop(PreInfo, Cases0, Cases, [], PostInfos, !Info),
|
|
merge_post_branch_infos_into_one(PostInfos, PostInfo),
|
|
set_post_branch_info(PostInfo, !Info)
|
|
).
|
|
|
|
:- pred ho_traverse_cases_loop(pre_branch_info::in,
|
|
list(case)::in, list(case)::out,
|
|
list(post_branch_info)::in, list(post_branch_info)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
ho_traverse_cases_loop(_, [], [], !PostInfos, !Info).
|
|
ho_traverse_cases_loop(PreInfo, [Case0 | Cases0], [Case | Cases], !PostInfos,
|
|
!Info) :-
|
|
set_pre_branch_info(PreInfo, !Info),
|
|
Case0 = case(MainConsId, OtherConsIds, Goal0),
|
|
ho_traverse_goal(Goal0, Goal, !Info),
|
|
Case = case(MainConsId, OtherConsIds, Goal),
|
|
get_post_branch_info_for_goal(!.Info, Goal, GoalPostInfo),
|
|
!:PostInfos = [GoalPostInfo | !.PostInfos],
|
|
ho_traverse_cases_loop(PreInfo, Cases0, Cases, !PostInfos, !Info).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type pre_branch_info
|
|
---> pre_branch_info(known_var_map).
|
|
|
|
:- type reachability
|
|
---> reachable
|
|
; unreachable.
|
|
|
|
:- type post_branch_info
|
|
---> post_branch_info(known_var_map, reachability).
|
|
|
|
:- pred get_pre_branch_info(higher_order_info::in, pre_branch_info::out)
|
|
is det.
|
|
|
|
get_pre_branch_info(Info, pre_branch_info(Info ^ hoi_known_var_map)).
|
|
|
|
:- pred set_pre_branch_info(pre_branch_info::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
set_pre_branch_info(pre_branch_info(KnownVarMap), !Info) :-
|
|
!Info ^ hoi_known_var_map := KnownVarMap.
|
|
|
|
:- pred get_post_branch_info_for_goal(higher_order_info::in, hlds_goal::in,
|
|
post_branch_info::out) is det.
|
|
|
|
get_post_branch_info_for_goal(HOInfo, Goal, PostBranchInfo) :-
|
|
InstMapDelta = goal_info_get_instmap_delta(Goal ^ hg_info),
|
|
( if instmap_delta_is_reachable(InstMapDelta) then
|
|
Reachability = reachable
|
|
else
|
|
Reachability = unreachable
|
|
),
|
|
PostBranchInfo =
|
|
post_branch_info(HOInfo ^ hoi_known_var_map, Reachability).
|
|
|
|
:- pred set_post_branch_info(post_branch_info::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
set_post_branch_info(post_branch_info(KnownVarMap, _), !Info) :-
|
|
!Info ^ hoi_known_var_map := KnownVarMap.
|
|
|
|
% Merge a bunch of post_branch_infos into one.
|
|
%
|
|
:- pred merge_post_branch_infos_into_one(list(post_branch_info)::in,
|
|
post_branch_info::out) is det.
|
|
|
|
merge_post_branch_infos_into_one(PostInfos, MergedPostInfo) :-
|
|
(
|
|
PostInfos = [],
|
|
unexpected($pred, "PostInfos = []")
|
|
;
|
|
PostInfos = [_ | _],
|
|
IsReachable =
|
|
( pred(PostInfo::in, VarMap::out) is semidet :-
|
|
PostInfo = post_branch_info(VarMap, reachable)
|
|
),
|
|
list.filter_map(IsReachable, PostInfos, ReachableVarMaps),
|
|
(
|
|
ReachableVarMaps = [],
|
|
MergedPostInfo = post_branch_info(map.init, unreachable)
|
|
;
|
|
ReachableVarMaps = [HeadVarMap | TailVarMaps],
|
|
merge_post_branch_var_maps_passes(HeadVarMap, TailVarMaps,
|
|
MergedVarMap),
|
|
MergedPostInfo = post_branch_info(MergedVarMap, reachable)
|
|
)
|
|
).
|
|
|
|
:- pred merge_post_branch_var_maps_passes(known_var_map::in,
|
|
list(known_var_map)::in, known_var_map::out) is det.
|
|
|
|
merge_post_branch_var_maps_passes(VarMap1, VarMaps2Plus, MergedVarMap) :-
|
|
merge_post_branch_var_maps_pass(VarMap1, VarMaps2Plus,
|
|
HeadMergedVarMap, TailMergedVarMaps),
|
|
(
|
|
TailMergedVarMaps = [],
|
|
MergedVarMap = HeadMergedVarMap
|
|
;
|
|
TailMergedVarMaps = [_ | _],
|
|
merge_post_branch_var_maps_passes(HeadMergedVarMap, TailMergedVarMaps,
|
|
MergedVarMap)
|
|
).
|
|
|
|
:- pred merge_post_branch_var_maps_pass(known_var_map::in,
|
|
list(known_var_map)::in,
|
|
known_var_map::out, list(known_var_map)::out) is det.
|
|
|
|
merge_post_branch_var_maps_pass(VarMap1, VarMaps2Plus,
|
|
HeadMergedVarMap, TailMergedVarMaps) :-
|
|
(
|
|
VarMaps2Plus = [],
|
|
HeadMergedVarMap = VarMap1,
|
|
TailMergedVarMaps = []
|
|
;
|
|
VarMaps2Plus = [VarMap2 | VarMaps3Plus],
|
|
merge_post_branch_known_var_maps(VarMap1, VarMap2, HeadMergedVarMap),
|
|
(
|
|
VarMaps3Plus = [],
|
|
TailMergedVarMaps = []
|
|
;
|
|
VarMaps3Plus = [VarMap3 | VarMaps4Plus],
|
|
merge_post_branch_var_maps_pass(VarMap3, VarMaps4Plus,
|
|
HeadTailMergedVarMap, TailTailMergedVarMaps),
|
|
TailMergedVarMaps = [HeadTailMergedVarMap | TailTailMergedVarMaps]
|
|
)
|
|
).
|
|
|
|
% Merge two the known_var_maps of post_branch_infos.
|
|
%
|
|
% If a variable appears in one post_branch_info, but not the other,
|
|
% it is dropped. Such a variable is either local to the branch arm,
|
|
% in which case no subsequent specialization opportunities exist,
|
|
% or it does not have a unique constant value in one of the branch arms,
|
|
% so we can't specialize it outside the branch anyway. A third possibility
|
|
% is that the branch without the variable is unreachable. In that case
|
|
% we include the variable in the result.
|
|
%
|
|
:- pred merge_post_branch_known_var_maps(known_var_map::in,
|
|
known_var_map::in, known_var_map::out) is det.
|
|
|
|
merge_post_branch_known_var_maps(VarConstMapA, VarConstMapB, VarConstMapAB) :-
|
|
map.keys_as_set(VarConstMapA, VarsA),
|
|
map.keys_as_set(VarConstMapB, VarsB),
|
|
set.intersect(VarsA, VarsB, CommonVars),
|
|
VarConstCommonMapA = map.select(VarConstMapA, CommonVars),
|
|
VarConstCommonMapB = map.select(VarConstMapB, CommonVars),
|
|
map.to_assoc_list(VarConstCommonMapA, VarConstCommonListA),
|
|
map.to_assoc_list(VarConstCommonMapB, VarConstCommonListB),
|
|
merge_common_var_const_list(VarConstCommonListA, VarConstCommonListB,
|
|
[], VarConstCommonList),
|
|
map.from_assoc_list(VarConstCommonList, VarConstMapAB).
|
|
|
|
:- pred merge_post_branch_infos(post_branch_info::in,
|
|
post_branch_info::in, post_branch_info::out) is det.
|
|
|
|
merge_post_branch_infos(PostA, PostB, Post) :-
|
|
(
|
|
PostA = post_branch_info(VarConstMapA, reachable),
|
|
PostB = post_branch_info(VarConstMapB, reachable),
|
|
merge_post_branch_known_var_maps(VarConstMapA, VarConstMapB,
|
|
VarConstMapAB),
|
|
Post = post_branch_info(VarConstMapAB, reachable)
|
|
;
|
|
PostA = post_branch_info(_, unreachable),
|
|
PostB = post_branch_info(_, reachable),
|
|
Post = PostB
|
|
;
|
|
PostA = post_branch_info(_, reachable),
|
|
PostB = post_branch_info(_, unreachable),
|
|
Post = PostA
|
|
;
|
|
PostA = post_branch_info(_, unreachable),
|
|
PostB = post_branch_info(_, unreachable),
|
|
Post = post_branch_info(map.init, unreachable)
|
|
).
|
|
|
|
:- pred merge_common_var_const_list(assoc_list(prog_var, known_const)::in,
|
|
assoc_list(prog_var, known_const)::in,
|
|
assoc_list(prog_var, known_const)::in,
|
|
assoc_list(prog_var, known_const)::out) is det.
|
|
|
|
merge_common_var_const_list([], [], !List).
|
|
merge_common_var_const_list([], [_ | _], !MergedList) :-
|
|
unexpected($pred, "mismatched list").
|
|
merge_common_var_const_list([_ | _], [], !MergedList) :-
|
|
unexpected($pred, "mismatched list").
|
|
merge_common_var_const_list([VarA - ValueA | ListA], [VarB - ValueB | ListB],
|
|
!MergedList) :-
|
|
expect(unify(VarA, VarB), $pred, "var mismatch"),
|
|
( if ValueA = ValueB then
|
|
!:MergedList = [VarA - ValueA | !.MergedList]
|
|
else
|
|
!:MergedList = !.MergedList
|
|
),
|
|
merge_common_var_const_list(ListA, ListB, !MergedList).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred check_unify(unification::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
check_unify(Unification, !Info) :-
|
|
(
|
|
Unification = simple_test(_, _)
|
|
% Testing two higher order terms for equality is not allowed.
|
|
;
|
|
Unification = assign(Var1, Var2),
|
|
maybe_add_alias(Var1, Var2, !Info)
|
|
;
|
|
Unification = deconstruct(_, _, _, _, _, _)
|
|
% Deconstructing a higher order term is not allowed.
|
|
;
|
|
Unification = construct(LVar, ConsId, Args, _Modes, _, _, _),
|
|
Params = !.Info ^ hoi_global_info ^ hogi_params,
|
|
IsInteresting = is_interesting_cons_id(Params, ConsId),
|
|
(
|
|
IsInteresting = yes,
|
|
KnownVarMap0 = !.Info ^ hoi_known_var_map,
|
|
% A variable cannot be constructed twice.
|
|
map.det_insert(LVar, known_const(ConsId, Args),
|
|
KnownVarMap0, KnownVarMap),
|
|
!Info ^ hoi_known_var_map := KnownVarMap
|
|
;
|
|
IsInteresting = no
|
|
)
|
|
;
|
|
Unification = complicated_unify(_, _, _),
|
|
unexpected($pred, "complicated unification")
|
|
).
|
|
|
|
:- func is_interesting_cons_id(ho_params, cons_id) = bool.
|
|
|
|
is_interesting_cons_id(Params, ConsId) = IsInteresting :-
|
|
(
|
|
( ConsId = cons(_, _, _)
|
|
; ConsId = tuple_cons(_)
|
|
; ConsId = float_const(_)
|
|
; ConsId = char_const(_)
|
|
; ConsId = string_const(_)
|
|
; ConsId = impl_defined_const(_)
|
|
; ConsId = ground_term_const(_, _)
|
|
; ConsId = tabling_info_const(_)
|
|
; ConsId = deep_profiling_proc_layout(_)
|
|
; ConsId = table_io_entry_desc(_)
|
|
),
|
|
IsInteresting = no
|
|
;
|
|
ConsId = some_int_const(IntConst),
|
|
(
|
|
( IntConst = uint_const(_)
|
|
; IntConst = int8_const(_)
|
|
; IntConst = uint8_const(_)
|
|
; IntConst = int16_const(_)
|
|
; IntConst = uint16_const(_)
|
|
; IntConst = int32_const(_)
|
|
; IntConst = uint32_const(_)
|
|
; IntConst = int64_const(_)
|
|
; IntConst = uint64_const(_)
|
|
),
|
|
IsInteresting = no
|
|
;
|
|
% We need to keep track of int_consts so we can interpret
|
|
% calls to the builtins superclass_info_from_typeclass_info and
|
|
% typeinfo_from_typeclass_info. We do not specialize based on
|
|
% integers alone.
|
|
IntConst = int_const(_),
|
|
UserTypeSpec = Params ^ param_do_user_type_spec,
|
|
(
|
|
UserTypeSpec = spec_types_user_guided,
|
|
IsInteresting = yes
|
|
;
|
|
UserTypeSpec = do_not_spec_types_user_guided,
|
|
IsInteresting = no
|
|
)
|
|
)
|
|
;
|
|
( ConsId = type_ctor_info_const(_, _, _)
|
|
; ConsId = base_typeclass_info_const(_, _, _, _)
|
|
; ConsId = type_info_cell_constructor(_)
|
|
; ConsId = typeclass_info_cell_constructor
|
|
; ConsId = type_info_const(_)
|
|
; ConsId = typeclass_info_const(_)
|
|
),
|
|
UserTypeSpec = Params ^ param_do_user_type_spec,
|
|
(
|
|
UserTypeSpec = spec_types_user_guided,
|
|
IsInteresting = yes
|
|
;
|
|
UserTypeSpec = do_not_spec_types_user_guided,
|
|
IsInteresting = no
|
|
)
|
|
;
|
|
ConsId = closure_cons(_, _),
|
|
HigherOrder = Params ^ param_do_higher_order_spec,
|
|
(
|
|
HigherOrder = opt_higher_order,
|
|
IsInteresting = yes
|
|
;
|
|
HigherOrder = do_not_opt_higher_order,
|
|
IsInteresting = no
|
|
)
|
|
).
|
|
|
|
% Process a higher-order call to see if it could possibly be specialized.
|
|
%
|
|
:- pred maybe_specialize_higher_order_call(prog_var::in,
|
|
list(prog_var)::in, hlds_goal::in, hlds_goal::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_specialize_higher_order_call(PredVar, Args, Goal0, Goal, !Info) :-
|
|
% We can specialize calls to call/N if the closure has a known value.
|
|
( if
|
|
map.search(!.Info ^ hoi_known_var_map, PredVar,
|
|
known_const(ConsId, CurriedArgs)),
|
|
ConsId = closure_cons(ShroudedPredProcId, _)
|
|
then
|
|
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
AllArgs = CurriedArgs ++ Args,
|
|
Goal0 = hlds_goal(_, GoalInfo),
|
|
construct_specialized_higher_order_call(PredId, ProcId, AllArgs,
|
|
GoalInfo, Goal, !Info)
|
|
else
|
|
% Non-specializable call/N.
|
|
Goal = Goal0
|
|
).
|
|
|
|
% Process a class_method_call to see if it could possibly be specialized.
|
|
%
|
|
:- pred maybe_specialize_method_call(prog_var::in, method_proc_num::in,
|
|
list(prog_var)::in, hlds_goal::in, hlds_goal::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_specialize_method_call(TypeClassInfoVar, MethodProcNum, Args,
|
|
Goal0, Goal, !Info) :-
|
|
MethodProcNum = method_proc_num(MethodNum),
|
|
Goal0 = hlds_goal(_GoalExpr0, GoalInfo0),
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
% We can specialize calls to class_method_call/N if the typeclass_info
|
|
% has a known value.
|
|
( if
|
|
% XXX We could duplicate this code, replacing the tests of
|
|
% ConsId and BaseConsId with equivalent tests on const_structs.
|
|
% However, how would we compute an equivalent of
|
|
% InstanceConstraintArgs?
|
|
map.search(!.Info ^ hoi_known_var_map, TypeClassInfoVar,
|
|
known_const(ConsId, TCIArgs)),
|
|
% A typeclass_info variable should consist of a known
|
|
% base_typeclass_info and some argument typeclass_infos.
|
|
ConsId = typeclass_info_cell_constructor,
|
|
TCIArgs = [BaseTypeClassInfo | OtherTypeClassInfoArgs],
|
|
map.search(!.Info ^ hoi_known_var_map, BaseTypeClassInfo,
|
|
known_const(BaseConsId, _)),
|
|
BaseConsId = base_typeclass_info_const(_, ClassId, Instance, _),
|
|
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
map.lookup(InstanceTable, ClassId, InstanceList),
|
|
list.det_index1(InstanceList, Instance, InstanceDefn),
|
|
InstanceDefn = hlds_instance_defn(_, _, _, _, InstanceTypes0,
|
|
InstanceConstraints, _,_, _, yes(MethodInfos), _),
|
|
type_vars_in_types(InstanceTypes0, InstanceTvars),
|
|
get_unconstrained_tvars(InstanceTvars,
|
|
InstanceConstraints, UnconstrainedTVars),
|
|
NumArgsToExtract = list.length(InstanceConstraints)
|
|
+ list.length(UnconstrainedTVars),
|
|
list.take(NumArgsToExtract, OtherTypeClassInfoArgs,
|
|
InstanceConstraintArgs)
|
|
then
|
|
list.det_index1(MethodInfos, MethodNum, MethodInfo),
|
|
MethodInfo ^ method_cur_proc = proc(PredId, ProcId),
|
|
AllArgs = InstanceConstraintArgs ++ Args,
|
|
construct_specialized_higher_order_call(PredId, ProcId, AllArgs,
|
|
GoalInfo0, Goal, !Info)
|
|
else if
|
|
% 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.
|
|
|
|
CallerProcInfo0 = !.Info ^ hoi_proc_info,
|
|
CallerPredInfo0 = !.Info ^ hoi_pred_info,
|
|
proc_info_get_rtti_varmaps(CallerProcInfo0, CallerRttiVarMaps),
|
|
rtti_varmaps_var_info(CallerRttiVarMaps, TypeClassInfoVar,
|
|
typeclass_info_var(ClassConstraint)),
|
|
ClassConstraint = constraint(ClassName, ClassArgTypes),
|
|
list.length(ClassArgTypes, ClassArity),
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
map.lookup(InstanceTable, class_id(ClassName, ClassArity), Instances),
|
|
pred_info_get_typevarset(CallerPredInfo0, TVarSet0),
|
|
find_matching_instance_method(Instances, MethodNum, ClassArgTypes,
|
|
PredId, ProcId, InstanceConstraints, UnconstrainedTVarTypes,
|
|
TVarSet0, TVarSet)
|
|
then
|
|
pred_info_set_typevarset(TVarSet, CallerPredInfo0, CallerPredInfo),
|
|
% Pull out the argument typeclass_infos.
|
|
( if
|
|
InstanceConstraints = [],
|
|
UnconstrainedTVarTypes = []
|
|
then
|
|
ExtraGoals = [],
|
|
CallerProcInfo = CallerProcInfo0,
|
|
AllArgs = Args
|
|
else
|
|
get_unconstrained_instance_type_infos(ModuleInfo,
|
|
TypeClassInfoVar, UnconstrainedTVarTypes, 1,
|
|
ArgTypeInfoGoals, ArgTypeInfoVars,
|
|
CallerProcInfo0, CallerProcInfo1),
|
|
FirstArgTypeclassInfo = list.length(UnconstrainedTVarTypes) + 1,
|
|
get_arg_typeclass_infos(ModuleInfo, TypeClassInfoVar,
|
|
InstanceConstraints, FirstArgTypeclassInfo,
|
|
ArgTypeClassInfoGoals, ArgTypeClassInfoVars,
|
|
CallerProcInfo1, CallerProcInfo),
|
|
list.condense([ArgTypeInfoVars, ArgTypeClassInfoVars, Args],
|
|
AllArgs),
|
|
ExtraGoals = ArgTypeInfoGoals ++ ArgTypeClassInfoGoals
|
|
),
|
|
!Info ^ hoi_pred_info := CallerPredInfo,
|
|
!Info ^ hoi_proc_info := CallerProcInfo,
|
|
construct_specialized_higher_order_call(PredId, ProcId,
|
|
AllArgs, GoalInfo0, SpecGoal, !Info),
|
|
conj_list_to_goal(ExtraGoals ++ [SpecGoal], GoalInfo0, Goal)
|
|
else
|
|
% Non-specializable class_method_call/N.
|
|
Goal = Goal0
|
|
).
|
|
|
|
:- pred find_matching_instance_method(list(hlds_instance_defn)::in, int::in,
|
|
list(mer_type)::in, pred_id::out, proc_id::out,
|
|
list(prog_constraint)::out, list(mer_type)::out,
|
|
tvarset::in, tvarset::out) is semidet.
|
|
|
|
find_matching_instance_method([Instance | Instances], MethodNum, ClassTypes,
|
|
PredId, ProcId, Constraints, UnconstrainedTVarTypes, !TVarSet) :-
|
|
( if
|
|
instance_matches(ClassTypes, Instance, Constraints0,
|
|
UnconstrainedTVarTypes0, !TVarSet)
|
|
then
|
|
Constraints = Constraints0,
|
|
UnconstrainedTVarTypes = UnconstrainedTVarTypes0,
|
|
Instance ^ instdefn_maybe_method_infos = yes(MethodInfos),
|
|
list.det_index1(MethodInfos, MethodNum, MethodInfo),
|
|
MethodInfo ^ method_cur_proc = proc(PredId, ProcId)
|
|
else
|
|
find_matching_instance_method(Instances, MethodNum, ClassTypes,
|
|
PredId, ProcId, Constraints, UnconstrainedTVarTypes, !TVarSet)
|
|
).
|
|
|
|
:- pred instance_matches(list(mer_type)::in, hlds_instance_defn::in,
|
|
list(prog_constraint)::out, list(mer_type)::out,
|
|
tvarset::in, tvarset::out) is semidet.
|
|
|
|
instance_matches(ClassTypes, Instance, Constraints, UnconstrainedTVarTypes,
|
|
TVarSet0, TVarSet) :-
|
|
Instance = hlds_instance_defn(_, _, InstanceTVarSet, _, InstanceTypes0,
|
|
Constraints0, _, _, _, _, _),
|
|
tvarset_merge_renaming(TVarSet0, InstanceTVarSet, TVarSet, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
|
|
InstanceTypes),
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming, Constraints0,
|
|
Constraints1),
|
|
type_vars_in_types(InstanceTypes, InstanceTVars),
|
|
get_unconstrained_tvars(InstanceTVars, Constraints1, UnconstrainedTVars0),
|
|
|
|
type_list_subsumes(InstanceTypes, ClassTypes, Subst),
|
|
apply_rec_subst_to_prog_constraint_list(Subst, Constraints1, Constraints),
|
|
|
|
% XXX kind inference:
|
|
% we assume all tvars have kind `star'.
|
|
map.init(KindMap),
|
|
apply_rec_subst_to_tvar_list(KindMap, Subst, UnconstrainedTVars0,
|
|
UnconstrainedTVarTypes).
|
|
|
|
% 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(module_info::in, prog_var::in,
|
|
list(prog_constraint)::in, int::in, list(hlds_goal)::out,
|
|
list(prog_var)::out, proc_info::in, proc_info::out) is det.
|
|
|
|
get_arg_typeclass_infos(ModuleInfo, TypeClassInfoVar, InstanceConstraints,
|
|
Index, Goals, Vars, !ProcInfo) :-
|
|
MakeResultType = (func(_) = typeclass_info_type),
|
|
get_typeclass_info_args(ModuleInfo, TypeClassInfoVar,
|
|
"instance_constraint_from_typeclass_info", MakeResultType,
|
|
InstanceConstraints, Index, Goals, Vars, !ProcInfo).
|
|
|
|
% Build calls to
|
|
% `private_builtin.unconstrained_type_info_from_typeclass_info/3'
|
|
% to extract the type-infos for the unconstrained type variables
|
|
% of an instance declaration.
|
|
% This simulates the action of `do_call_class_method' in
|
|
% runtime/mercury_ho_call.c.
|
|
%
|
|
:- pred get_unconstrained_instance_type_infos(module_info::in,
|
|
prog_var::in, list(mer_type)::in, int::in, list(hlds_goal)::out,
|
|
list(prog_var)::out, proc_info::in, proc_info::out) is det.
|
|
|
|
get_unconstrained_instance_type_infos(ModuleInfo, TypeClassInfoVar,
|
|
UnconstrainedTVarTypes, Index, Goals, Vars, !ProcInfo) :-
|
|
MakeResultType = build_type_info_type,
|
|
get_typeclass_info_args(ModuleInfo, TypeClassInfoVar,
|
|
"unconstrained_type_info_from_typeclass_info",
|
|
MakeResultType, UnconstrainedTVarTypes,
|
|
Index, Goals, Vars, !ProcInfo).
|
|
|
|
:- pred get_typeclass_info_args(module_info::in, prog_var::in, string::in,
|
|
(func(T) = mer_type)::in, list(T)::in, int::in, list(hlds_goal)::out,
|
|
list(prog_var)::out, proc_info::in, proc_info::out) is det.
|
|
|
|
get_typeclass_info_args(ModuleInfo, TypeClassInfoVar, PredName, MakeResultType,
|
|
Args, Index, Goals, Vars, !ProcInfo) :-
|
|
lookup_builtin_pred_proc_id(ModuleInfo, mercury_private_builtin_module,
|
|
PredName, pf_predicate, user_arity(3), only_mode, ExtractArgPredId,
|
|
ExtractArgProcId),
|
|
get_typeclass_info_args_loop(ModuleInfo, TypeClassInfoVar,
|
|
ExtractArgPredId, ExtractArgProcId,
|
|
qualified(mercury_private_builtin_module, PredName),
|
|
MakeResultType, Args, Index, Goals, Vars, !ProcInfo).
|
|
|
|
:- pred get_typeclass_info_args_loop(module_info::in, prog_var::in,
|
|
pred_id::in, proc_id::in, sym_name::in, (func(T) = mer_type)::in,
|
|
list(T)::in, int::in, list(hlds_goal)::out,
|
|
list(prog_var)::out, proc_info::in, proc_info::out) is det.
|
|
|
|
get_typeclass_info_args_loop(_, _, _, _, _, _, [], _, [], [], !ProcInfo).
|
|
get_typeclass_info_args_loop(ModuleInfo, TypeClassInfoVar, PredId, ProcId,
|
|
SymName, MakeResultType, [Arg | Args], Index,
|
|
[IndexGoal, CallGoal | Goals], [ResultVar | Vars], !ProcInfo) :-
|
|
ResultType = MakeResultType(Arg),
|
|
IsDummy = is_type_a_dummy(ModuleInfo, ResultType),
|
|
proc_info_create_var_from_type("", ResultType, IsDummy,
|
|
ResultVar, !ProcInfo),
|
|
MaybeContext = no,
|
|
make_int_const_construction_alloc_in_proc(Index, "", IndexGoal, IndexVar,
|
|
!ProcInfo),
|
|
CallArgs = [TypeClassInfoVar, IndexVar, ResultVar],
|
|
|
|
set_of_var.list_to_set(CallArgs, NonLocals),
|
|
instmap_delta_init_reachable(InstMapDelta0),
|
|
instmap_delta_insert_var(ResultVar, ground(shared, none_or_default_func),
|
|
InstMapDelta0, InstMapDelta),
|
|
goal_info_init(NonLocals, InstMapDelta, detism_det, purity_pure, GoalInfo),
|
|
CallGoalExpr = plain_call(PredId, ProcId, CallArgs, not_builtin,
|
|
MaybeContext, SymName),
|
|
CallGoal = hlds_goal(CallGoalExpr, GoalInfo),
|
|
get_typeclass_info_args_loop(ModuleInfo, TypeClassInfoVar, PredId, ProcId,
|
|
SymName, MakeResultType, Args, Index + 1, Goals, Vars, !ProcInfo).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred construct_specialized_higher_order_call(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(PredId, ProcId, AllArgs, GoalInfo,
|
|
hlds_goal(GoalExpr, GoalInfo), !Info) :-
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
ModuleName = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
SymName = qualified(ModuleName, PredName),
|
|
proc(CallerPredId, _) = !.Info ^ hoi_pred_proc_id,
|
|
Builtin = builtin_state(ModuleInfo, CallerPredId, PredId, ProcId),
|
|
|
|
MaybeContext = no,
|
|
GoalExpr1 = plain_call(PredId, ProcId, AllArgs, Builtin, MaybeContext,
|
|
SymName),
|
|
!Info ^ hoi_changed := hoc_changed,
|
|
maybe_specialize_call(hlds_goal(GoalExpr1, GoalInfo),
|
|
hlds_goal(GoalExpr, _), !Info).
|
|
|
|
:- pred maybe_specialize_call(hlds_goal::in(goal_plain_call), hlds_goal::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_specialize_call(hlds_goal(GoalExpr0, GoalInfo),
|
|
hlds_goal(GoalExpr, GoalInfo), !Info) :-
|
|
ModuleInfo0 = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
GoalExpr0 = plain_call(CalledPred, CalledProc, Args0, IsBuiltin,
|
|
MaybeContext, _SymName0),
|
|
module_info_pred_proc_info(ModuleInfo0, CalledPred, CalledProc,
|
|
CalleePredInfo, CalleeProcInfo),
|
|
( if
|
|
% Look for calls to unify/2 and compare/3 that can be specialized.
|
|
specialize_special_pred(CalledPred, CalledProc, Args0,
|
|
MaybeContext, GoalInfo, GoalExpr1, !Info)
|
|
then
|
|
GoalExpr = GoalExpr1,
|
|
!Info ^ hoi_changed := hoc_changed
|
|
else if
|
|
is_typeclass_info_manipulator(ModuleInfo0, CalledPred, Manipulator)
|
|
then
|
|
interpret_typeclass_info_manipulator(Manipulator, Args0,
|
|
GoalExpr0, GoalExpr, !Info)
|
|
else if
|
|
(
|
|
pred_info_is_imported(CalleePredInfo),
|
|
module_info_get_type_spec_info(ModuleInfo0, TypeSpecInfo),
|
|
TypeSpecInfo = type_spec_info(TypeSpecProcs, _, _, _),
|
|
not set.member(proc(CalledPred, CalledProc), TypeSpecProcs)
|
|
;
|
|
pred_info_is_pseudo_imported(CalleePredInfo),
|
|
hlds_pred.in_in_unification_proc_id(CalledProc)
|
|
;
|
|
pred_info_defn_has_foreign_proc(CalleePredInfo)
|
|
)
|
|
then
|
|
GoalExpr = GoalExpr0
|
|
else
|
|
maybe_specialize_ordinary_call(can_request, CalledPred, CalledProc,
|
|
CalleePredInfo, CalleeProcInfo, Args0, IsBuiltin, MaybeContext,
|
|
GoalInfo, Result, !Info),
|
|
(
|
|
Result = specialized(ExtraTypeInfoGoals, GoalExpr1),
|
|
goal_to_conj_list(hlds_goal(GoalExpr1, GoalInfo), GoalList1),
|
|
GoalList = ExtraTypeInfoGoals ++ GoalList1,
|
|
GoalExpr = conj(plain_conj, GoalList)
|
|
;
|
|
Result = not_specialized,
|
|
GoalExpr = GoalExpr0
|
|
)
|
|
).
|
|
|
|
% Try to specialize constructions of higher-order terms.
|
|
% This is useful if we don't have the code for predicates
|
|
% to which this higher-order term is passed.
|
|
%
|
|
% The specialization is done by treating
|
|
% Pred = foo(A, B, ...)
|
|
% as
|
|
% pred(X::<mode1>, Y::<mode2>, ...) is <det> :-
|
|
% foo(A, B, ..., X, Y, ...)
|
|
% and specializing the call.
|
|
%
|
|
:- pred maybe_specialize_pred_const(hlds_goal::in, hlds_goal::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_specialize_pred_const(hlds_goal(GoalExpr0, GoalInfo),
|
|
hlds_goal(GoalExpr, GoalInfo), !Info) :-
|
|
NewPredMap = !.Info ^ hoi_global_info ^ hogi_new_pred_map,
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
( if
|
|
GoalExpr0 = unify(_, _, UniMode, Unify0, Context),
|
|
Unify0 = construct(LVar, ConsId0, Args0, _,
|
|
HowToConstruct, CellIsUnique, SubInfo),
|
|
(
|
|
SubInfo = no_construct_sub_info
|
|
;
|
|
SubInfo = construct_sub_info(no, no)
|
|
),
|
|
ConsId0 = closure_cons(ShroudedPredProcId, EvalMethod),
|
|
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
proc(PredId, ProcId) = PredProcId,
|
|
map.contains(NewPredMap, PredProcId),
|
|
proc_info_get_var_table(ProcInfo0, VarTable0),
|
|
lookup_var_type(VarTable0, LVar, LVarType),
|
|
type_is_higher_order_details(LVarType, _, _, _, ArgTypes)
|
|
then
|
|
proc_info_create_vars_from_types(ModuleInfo, ArgTypes, UncurriedArgs,
|
|
ProcInfo0, ProcInfo1),
|
|
Args1 = Args0 ++ UncurriedArgs,
|
|
!Info ^ hoi_proc_info := ProcInfo1,
|
|
|
|
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
|
|
CalleePredInfo, CalleeProcInfo),
|
|
|
|
% We don't create requests for higher-order terms because that would
|
|
% result in duplication of effort if all uses of the constant end up
|
|
% being specialized. For parser combinator programs it would also
|
|
% result in huge numbers of requests with no easy way to control which
|
|
% ones should be created.
|
|
|
|
IsBuiltin = not_builtin,
|
|
MaybeContext = no,
|
|
maybe_specialize_ordinary_call(can_not_request, PredId, ProcId,
|
|
CalleePredInfo, CalleeProcInfo, Args1, IsBuiltin, MaybeContext,
|
|
GoalInfo, Result, !Info),
|
|
(
|
|
Result = specialized(ExtraTypeInfoGoals0, GoalExpr1),
|
|
( if
|
|
GoalExpr1 =
|
|
plain_call(NewPredId0, NewProcId0, NewArgs0, _, _, _),
|
|
list.remove_suffix(NewArgs0, UncurriedArgs, NewArgs1)
|
|
then
|
|
NewPredId = NewPredId0,
|
|
NewProcId = NewProcId0,
|
|
NewArgs = NewArgs1
|
|
else
|
|
unexpected($pred, "cannot get NewArgs")
|
|
),
|
|
|
|
module_info_proc_info(ModuleInfo, NewPredId, NewProcId,
|
|
NewCalleeProcInfo),
|
|
proc_info_get_argmodes(NewCalleeProcInfo, NewCalleeArgModes),
|
|
( if
|
|
list.take(list.length(NewArgs), NewCalleeArgModes,
|
|
CurriedArgModesPrime)
|
|
then
|
|
CurriedArgModes = CurriedArgModesPrime
|
|
else
|
|
unexpected($pred, "cannot get CurriedArgModes")
|
|
),
|
|
ArgModes = list.map(mode_both_sides_to_unify_mode(ModuleInfo),
|
|
CurriedArgModes),
|
|
|
|
% The dummy arguments can't be used anywhere.
|
|
ProcInfo2 = !.Info ^ hoi_proc_info,
|
|
proc_info_get_var_table(ProcInfo2, VarTable2),
|
|
delete_var_entries(UncurriedArgs, VarTable2, VarTable),
|
|
proc_info_set_var_table(VarTable, ProcInfo2, ProcInfo),
|
|
!Info ^ hoi_proc_info := ProcInfo,
|
|
|
|
NewPredProcId = proc(NewPredId, NewProcId),
|
|
NewShroudedPredProcId = shroud_pred_proc_id(NewPredProcId),
|
|
NewConsId = closure_cons(NewShroudedPredProcId, EvalMethod),
|
|
Unify = construct(LVar, NewConsId, NewArgs, ArgModes,
|
|
HowToConstruct, CellIsUnique, no_construct_sub_info),
|
|
GoalExpr2 = unify(LVar,
|
|
rhs_functor(NewConsId, is_not_exist_constr, NewArgs),
|
|
UniMode, Unify, Context),
|
|
|
|
% Make sure any constants in the ExtraTypeInfoGoals are recorded.
|
|
list.map_foldl(ho_traverse_goal, ExtraTypeInfoGoals0,
|
|
ExtraTypeInfoGoals, !Info),
|
|
(
|
|
ExtraTypeInfoGoals = [],
|
|
GoalExpr = GoalExpr2
|
|
;
|
|
ExtraTypeInfoGoals = [_ | _],
|
|
GoalExpr = conj(plain_conj,
|
|
ExtraTypeInfoGoals ++ [hlds_goal(GoalExpr2, GoalInfo)])
|
|
)
|
|
;
|
|
Result = not_specialized,
|
|
% The dummy arguments can't be used anywhere.
|
|
!Info ^ hoi_proc_info := ProcInfo0,
|
|
GoalExpr = GoalExpr0
|
|
)
|
|
else
|
|
GoalExpr = GoalExpr0
|
|
).
|
|
|
|
:- type specialization_result
|
|
---> specialized(
|
|
% Goals to construct extra type-infos.
|
|
list(hlds_goal),
|
|
|
|
% The specialized call.
|
|
hlds_goal_expr
|
|
)
|
|
; not_specialized.
|
|
|
|
:- type can_request
|
|
---> can_request
|
|
; can_not_request.
|
|
|
|
:- pred maybe_specialize_ordinary_call(can_request::in,
|
|
pred_id::in, proc_id::in, pred_info::in, proc_info::in,
|
|
list(prog_var)::in, builtin_state::in, maybe(call_unify_context)::in,
|
|
hlds_goal_info::in, specialization_result::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_specialize_ordinary_call(CanRequest, CalledPred, CalledProc,
|
|
CalleePredInfo, CalleeProcInfo, Args0, IsBuiltin,
|
|
MaybeContext, GoalInfo, Result, !Info) :-
|
|
ModuleInfo0 = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
pred_info_get_status(CalleePredInfo, CalleeStatus),
|
|
proc_info_get_var_table(CalleeProcInfo, CalleeVarTable),
|
|
proc_info_get_headvars(CalleeProcInfo, CalleeHeadVars),
|
|
lookup_var_types(CalleeVarTable, CalleeHeadVars, CalleeArgTypes),
|
|
|
|
CallerProcInfo0 = !.Info ^ hoi_proc_info,
|
|
proc_info_get_var_table(CallerProcInfo0, VarTable),
|
|
proc_info_get_rtti_varmaps(CallerProcInfo0, RttiVarMaps),
|
|
find_higher_order_args(ModuleInfo0, CalleeStatus, Args0,
|
|
CalleeArgTypes, VarTable, RttiVarMaps, !.Info ^ hoi_known_var_map, 1,
|
|
[], HigherOrderArgs0),
|
|
|
|
proc(CallerPredId, _) = !.Info ^ hoi_pred_proc_id,
|
|
module_info_get_type_spec_info(ModuleInfo0, TypeSpecInfo),
|
|
TypeSpecInfo = type_spec_info(_, ForceVersions, _, _),
|
|
( if set.contains(ForceVersions, CallerPredId) then
|
|
RequestKind = user_type_spec
|
|
else
|
|
RequestKind = non_user_type_spec
|
|
),
|
|
( if
|
|
(
|
|
HigherOrderArgs0 = [_ | _]
|
|
;
|
|
% We should create these even if there is no specialization
|
|
% to avoid link errors.
|
|
RequestKind = user_type_spec
|
|
;
|
|
!.Info ^ hoi_global_info ^ hogi_params ^ param_do_user_type_spec
|
|
= spec_types_user_guided,
|
|
lookup_var_types(VarTable, Args0, ArgTypes),
|
|
|
|
% Check whether any typeclass constraints now match an instance.
|
|
pred_info_get_class_context(CalleePredInfo, CalleeClassContext),
|
|
CalleeClassContext = constraints(CalleeUnivConstraints0, _),
|
|
pred_info_get_typevarset(CalleePredInfo, CalleeTVarSet),
|
|
pred_info_get_exist_quant_tvars(CalleePredInfo, CalleeExistQTVars),
|
|
CallerPredInfo0 = !.Info ^ hoi_pred_info,
|
|
pred_info_get_typevarset(CallerPredInfo0, TVarSet),
|
|
pred_info_get_univ_quant_tvars(CallerPredInfo0, CallerUnivQTVars),
|
|
type_subst_makes_instance_known(ModuleInfo0,
|
|
CalleeUnivConstraints0, TVarSet,
|
|
CallerUnivQTVars, ArgTypes, CalleeTVarSet,
|
|
CalleeExistQTVars, CalleeArgTypes)
|
|
)
|
|
then
|
|
list.reverse(HigherOrderArgs0, HigherOrderArgs),
|
|
Context = goal_info_get_context(GoalInfo),
|
|
find_matching_version(!.Info, CalledPred, CalledProc, Args0,
|
|
Context, HigherOrderArgs, RequestKind, FindResult),
|
|
(
|
|
FindResult = find_result_match(match(Match, _, Args1,
|
|
ExtraTypeInfoTypes)),
|
|
Match = new_pred(NewPredProcId, _, _, NewName, _, _, _, _, _, _),
|
|
NewPredProcId = proc(NewCalledPred, NewCalledProc),
|
|
|
|
construct_extra_type_infos(ExtraTypeInfoTypes,
|
|
ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
|
|
|
|
Args = ExtraTypeInfoVars ++ Args1,
|
|
CallGoal = plain_call(NewCalledPred, NewCalledProc, Args,
|
|
IsBuiltin, MaybeContext, NewName),
|
|
Result = specialized(ExtraTypeInfoGoals, CallGoal),
|
|
!Info ^ hoi_changed := hoc_changed
|
|
;
|
|
% There is a known higher order variable in the call, so we
|
|
% put in a request for a specialized version of the pred.
|
|
FindResult = find_result_request(Request),
|
|
Result = not_specialized,
|
|
(
|
|
CanRequest = can_request,
|
|
Requests0 = !.Info ^ hoi_global_info ^ hogi_requests,
|
|
Changed0 = !.Info ^ hoi_changed,
|
|
set.insert(Request, Requests0, Requests),
|
|
update_changed_status(Changed0, hoc_request, Changed),
|
|
!Info ^ hoi_global_info ^ hogi_requests := Requests,
|
|
!Info ^ hoi_changed := Changed
|
|
;
|
|
CanRequest = can_not_request
|
|
)
|
|
;
|
|
FindResult = find_result_no_request,
|
|
Result = not_specialized
|
|
)
|
|
else
|
|
Result = not_specialized
|
|
).
|
|
|
|
% Returns a list of the higher-order arguments in a call that have
|
|
% a known value.
|
|
%
|
|
:- pred find_higher_order_args(module_info::in, pred_status::in,
|
|
list(prog_var)::in, list(mer_type)::in, var_table::in,
|
|
rtti_varmaps::in, known_var_map::in, int::in, list(higher_order_arg)::in,
|
|
list(higher_order_arg)::out) is det.
|
|
|
|
find_higher_order_args(_, _, [], _, _, _, _, _, !HOArgs).
|
|
find_higher_order_args(_, _, [_ | _], [], _, _, _, _, _, _) :-
|
|
unexpected($pred, "length mismatch").
|
|
find_higher_order_args(ModuleInfo, CalleeStatus, [Arg | Args],
|
|
[CalleeArgType | CalleeArgTypes], VarTable, RttiVarMaps,
|
|
KnownVarMap, ArgNo, !HOArgs) :-
|
|
NextArg = ArgNo + 1,
|
|
( if
|
|
% We don't specialize arguments whose declared type is polymorphic.
|
|
% The closure they pass cannot possibly be called within the called
|
|
% predicate, since that predicate doesn't know it is a closure
|
|
% (without some dodgy use of type_to_univ and univ_to_type).
|
|
map.search(KnownVarMap, Arg, known_const(ConsId, CurriedArgs)),
|
|
|
|
% We don't specialize based on int_consts (we only keep track of them
|
|
% to interpret calls to the procedures which extract fields from
|
|
% typeclass_infos).
|
|
ConsId \= some_int_const(int_const(_)),
|
|
|
|
( if ConsId = closure_cons(_, _) then
|
|
% 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 \= pred_status(status_imported(_)),
|
|
CalleeStatus \= pred_status(status_external(_)),
|
|
type_is_higher_order(CalleeArgType)
|
|
else
|
|
true
|
|
)
|
|
then
|
|
% Find any known higher-order arguments in the list of curried
|
|
% arguments.
|
|
lookup_var_types(VarTable, CurriedArgs, CurriedArgTypes),
|
|
list.map(rtti_varmaps_var_info(RttiVarMaps), CurriedArgs,
|
|
CurriedArgRttiInfo),
|
|
( if ConsId = closure_cons(ShroudedPredProcId, _) then
|
|
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_arg_types(PredInfo, CurriedCalleeArgTypes)
|
|
else
|
|
CurriedCalleeArgTypes = CurriedArgTypes
|
|
),
|
|
find_higher_order_args(ModuleInfo, CalleeStatus, CurriedArgs,
|
|
CurriedCalleeArgTypes, VarTable, RttiVarMaps,
|
|
KnownVarMap, 1, [], HOCurriedArgs0),
|
|
list.reverse(HOCurriedArgs0, HOCurriedArgs),
|
|
list.length(CurriedArgs, NumArgs),
|
|
( if
|
|
NumArgs = list.length(HOCurriedArgs),
|
|
not (
|
|
list.member(HOCurriedArg, HOCurriedArgs),
|
|
HOCurriedArg ^ hoa_is_constant = no
|
|
)
|
|
then
|
|
IsConst = yes
|
|
else
|
|
IsConst = no
|
|
),
|
|
HOArg = higher_order_arg(ConsId, ArgNo, NumArgs,
|
|
CurriedArgs, CurriedArgTypes, CurriedArgRttiInfo,
|
|
HOCurriedArgs, IsConst),
|
|
list.cons(HOArg, !HOArgs)
|
|
else
|
|
true
|
|
),
|
|
find_higher_order_args(ModuleInfo, CalleeStatus, Args, CalleeArgTypes,
|
|
VarTable, RttiVarMaps, KnownVarMap, NextArg, !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(prog_constraint)::in, tvarset::in, list(tvar)::in, list(mer_type)::in,
|
|
tvarset::in, existq_tvars::in, list(mer_type)::in) is semidet.
|
|
|
|
type_subst_makes_instance_known(ModuleInfo, CalleeUnivConstraints0, TVarSet0,
|
|
CallerHeadTypeParams, ArgTypes, CalleeTVarSet,
|
|
CalleeExistQVars, CalleeArgTypes0) :-
|
|
CalleeUnivConstraints0 = [_ | _],
|
|
tvarset_merge_renaming(TVarSet0, CalleeTVarSet, TVarSet, TypeRenaming),
|
|
apply_variable_renaming_to_type_list(TypeRenaming, CalleeArgTypes0,
|
|
CalleeArgTypes1),
|
|
|
|
% Substitute the types in the callee's class constraints.
|
|
compute_caller_callee_type_substitution(CalleeArgTypes1, ArgTypes,
|
|
CallerHeadTypeParams, CalleeExistQVars, TypeSubn),
|
|
apply_variable_renaming_to_prog_constraint_list(TypeRenaming,
|
|
CalleeUnivConstraints0, CalleeUnivConstraints1),
|
|
apply_rec_subst_to_prog_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, ConstraintArgTypes0),
|
|
list.length(ConstraintArgTypes0, ClassArity),
|
|
CalleeUnivConstraint = constraint(_ClassName, ConstraintArgTypes),
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
map.search(InstanceTable, class_id(ClassName, ClassArity), Instances),
|
|
list.member(Instance, Instances),
|
|
instance_matches(ConstraintArgTypes, Instance, _, _, TVarSet, _),
|
|
not instance_matches(ConstraintArgTypes0, Instance, _, _, TVarSet, _).
|
|
|
|
:- type find_result
|
|
---> find_result_match(match)
|
|
; find_result_request(ho_request)
|
|
; find_result_no_request.
|
|
|
|
:- type match
|
|
---> match(
|
|
new_pred,
|
|
|
|
% Was the match partial, if so, how many higher_order arguments
|
|
% matched.
|
|
maybe(int),
|
|
|
|
% The arguments to the specialised call.
|
|
list(prog_var),
|
|
|
|
% Type variables for which extra type-infos must be added
|
|
% to the start of the argument list.
|
|
list(mer_type)
|
|
).
|
|
|
|
% WARNING - do not filter out higher-order arguments from the request
|
|
% returned by find_matching_version, otherwise some type-infos that the
|
|
% call specialization code is expecting to come from the curried arguments
|
|
% of the higher-order arguments will not be present in the specialized
|
|
% argument list.
|
|
%
|
|
:- pred find_matching_version(higher_order_info::in,
|
|
pred_id::in, proc_id::in, list(prog_var)::in, prog_context::in,
|
|
list(higher_order_arg)::in, ho_request_kind::in, find_result::out) is det.
|
|
|
|
find_matching_version(Info, CalledPred, CalledProc, Args0, Context,
|
|
HigherOrderArgs, RequestKind, Result) :-
|
|
% Args0 is the original list of arguments.
|
|
% Args is the original list of arguments with the curried arguments
|
|
% of known higher-order arguments added.
|
|
|
|
ModuleInfo = Info ^ hoi_global_info ^ hogi_module_info,
|
|
NewPredMap = Info ^ hoi_global_info ^ hogi_new_pred_map,
|
|
Caller = Info ^ hoi_pred_proc_id,
|
|
PredInfo = Info ^ hoi_pred_info,
|
|
ProcInfo = Info ^ hoi_proc_info,
|
|
Params = Info ^ hoi_global_info ^ hogi_params,
|
|
|
|
% WARNING - do not filter out higher-order arguments after this step,
|
|
% except when partially matching against a previously produced
|
|
% specialization, otherwise some type-infos that the call
|
|
% specialization code is expecting to come from the curried
|
|
% arguments of the higher-order arguments will not be present in the
|
|
% specialized argument list.
|
|
|
|
get_extra_arguments(HigherOrderArgs, Args0, Args),
|
|
compute_extra_typeinfos(Info, Args, ExtraTypeInfoTVars),
|
|
|
|
proc_info_get_var_table(ProcInfo, VarTable),
|
|
PairWithType =
|
|
( pred(V::in, (V - T)::out) is det :-
|
|
lookup_var_type(VarTable, V, T)
|
|
),
|
|
list.map(PairWithType, Args0, ArgsTypes0),
|
|
pred_info_get_typevarset(PredInfo, TVarSet),
|
|
|
|
Request = ho_request(Caller, proc(CalledPred, CalledProc), ArgsTypes0,
|
|
ExtraTypeInfoTVars, HigherOrderArgs, TVarSet, yes, RequestKind,
|
|
Context),
|
|
|
|
% Check to see if any of the specialized versions of the called pred
|
|
% apply here.
|
|
( if
|
|
map.search(NewPredMap, proc(CalledPred, CalledProc), Versions0),
|
|
set.to_sorted_list(Versions0, Versions),
|
|
search_for_version(Info, Params, ModuleInfo, Request, Versions,
|
|
no, Match)
|
|
then
|
|
Result = find_result_match(Match)
|
|
else if
|
|
HigherOrder = Params ^ param_do_higher_order_spec,
|
|
TypeSpec = Params ^ param_do_type_spec,
|
|
UserTypeSpec = Params ^ param_do_user_type_spec,
|
|
(
|
|
UserTypeSpec = spec_types_user_guided,
|
|
RequestKind = user_type_spec
|
|
;
|
|
module_info_pred_info(ModuleInfo, CalledPred, CalledPredInfo),
|
|
not pred_info_is_imported(CalledPredInfo),
|
|
(
|
|
% This handles the predicates introduced by check_typeclass.m
|
|
% to call the class methods for a specific instance. Without
|
|
% this, user-specified specialized versions of class methods
|
|
% won't be called.
|
|
UserTypeSpec = spec_types_user_guided,
|
|
pred_info_get_markers(CalledPredInfo, Markers),
|
|
(
|
|
check_marker(Markers, marker_class_method)
|
|
;
|
|
check_marker(Markers, marker_class_instance_method)
|
|
)
|
|
;
|
|
HigherOrder = opt_higher_order,
|
|
list.member(HOArg, HigherOrderArgs),
|
|
HOArg ^ hoa_cons_id = closure_cons(_, _)
|
|
;
|
|
TypeSpec = spec_types
|
|
)
|
|
)
|
|
then
|
|
Result = find_result_request(Request)
|
|
else
|
|
Result = find_result_no_request
|
|
).
|
|
|
|
% Specializing type `T' to `list(U)' requires passing in the
|
|
% typeinfo for `U'. This predicate works out which extra variables
|
|
% to pass in given the argument list for the call. This needs to be done
|
|
% even if --typeinfo-liveness is not set because the type-infos
|
|
% may be needed when specializing calls inside the specialized version.
|
|
%
|
|
:- pred compute_extra_typeinfos(higher_order_info::in,
|
|
list(prog_var)::in, list(tvar)::out) is det.
|
|
|
|
compute_extra_typeinfos(Info, Args, ExtraTypeInfoTVars) :-
|
|
% Work out which type variables don't already have type-infos in the
|
|
% list of argument types. The list is in the order which the type
|
|
% variables occur in the list of argument types so that the extra
|
|
% type-info arguments for calls to imported user-guided type
|
|
% specialization procedures can be matched against the specialized
|
|
% version (`goal_util.extra_nonlocal_typeinfos' is not used here
|
|
% because the type variables are returned sorted by variable number,
|
|
% which will vary between calls).
|
|
ProcInfo = Info ^ hoi_proc_info,
|
|
proc_info_get_var_table(ProcInfo, VarTable),
|
|
lookup_var_types(VarTable, Args, ArgTypes),
|
|
type_vars_in_types(ArgTypes, AllTVars),
|
|
(
|
|
AllTVars = [],
|
|
ExtraTypeInfoTVars = []
|
|
;
|
|
AllTVars = [_ | _],
|
|
proc_info_get_rtti_varmaps(Info ^ hoi_proc_info, RttiVarMaps),
|
|
list.foldl(arg_contains_type_info_for_tvar(RttiVarMaps),
|
|
Args, [], TypeInfoTVars),
|
|
list.delete_elems(AllTVars, TypeInfoTVars, ExtraTypeInfoTVars0),
|
|
list.remove_dups(ExtraTypeInfoTVars0, ExtraTypeInfoTVars)
|
|
).
|
|
|
|
:- pred arg_contains_type_info_for_tvar(rtti_varmaps::in, prog_var::in,
|
|
list(tvar)::in, list(tvar)::out) is det.
|
|
|
|
arg_contains_type_info_for_tvar(RttiVarMaps, Var, !TVars) :-
|
|
rtti_varmaps_var_info(RttiVarMaps, Var, VarInfo),
|
|
(
|
|
VarInfo = type_info_var(Type),
|
|
( if Type = type_variable(TVar, _) then
|
|
!:TVars = [TVar | !.TVars]
|
|
else
|
|
true
|
|
)
|
|
;
|
|
VarInfo = typeclass_info_var(Constraint),
|
|
Constraint = constraint(_ClassName, ClassArgTypes),
|
|
% Find out what tvars the typeclass-info contains the type-infos for.
|
|
list.filter_map(
|
|
( pred(ClassArgType::in, ClassTVar::out) is semidet :-
|
|
ClassArgType = type_variable(ClassTVar, _)
|
|
), ClassArgTypes, ClassTVars),
|
|
!:TVars = ClassTVars ++ !.TVars
|
|
;
|
|
VarInfo = non_rtti_var
|
|
).
|
|
|
|
:- pred construct_extra_type_infos(list(mer_type)::in,
|
|
list(prog_var)::out, list(hlds_goal)::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
construct_extra_type_infos(Types, TypeInfoVars, TypeInfoGoals, !Info) :-
|
|
ModuleInfo0 = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
PredInfo0 = !.Info ^ hoi_pred_info,
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
polymorphism_make_type_info_vars_mi(Types, dummy_context,
|
|
TypeInfoVars, TypeInfoGoals, ModuleInfo0, ModuleInfo,
|
|
PredInfo0, PredInfo, ProcInfo0, ProcInfo),
|
|
!Info ^ hoi_pred_info := PredInfo,
|
|
!Info ^ hoi_proc_info := ProcInfo,
|
|
!Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo.
|
|
|
|
:- pred search_for_version(higher_order_info::in, ho_params::in,
|
|
module_info::in, ho_request::in, list(new_pred)::in,
|
|
maybe(match)::in, match::out) is semidet.
|
|
|
|
search_for_version(_, _, _, _, [], yes(Match), Match).
|
|
search_for_version(Info, Params, ModuleInfo, Request, [Version | Versions],
|
|
MaybeMatch0, Match) :-
|
|
( if version_matches(Params, ModuleInfo, Request, Version, Match1) then
|
|
( if
|
|
Match1 = match(_, MatchIsPartial, _, _),
|
|
MatchIsPartial = no
|
|
then
|
|
Match = Match1
|
|
else
|
|
(
|
|
MaybeMatch0 = no,
|
|
MaybeMatch2 = yes(Match1)
|
|
;
|
|
MaybeMatch0 = yes(Match0),
|
|
( if
|
|
% Pick the best match.
|
|
Match0 = match(_, yes(NumMatches0), _, _),
|
|
Match1 = match(_, yes(NumMatches1), _, _)
|
|
then
|
|
( if NumMatches0 > NumMatches1 then
|
|
MaybeMatch2 = MaybeMatch0
|
|
else
|
|
MaybeMatch2 = yes(Match1)
|
|
)
|
|
else
|
|
unexpected($pred, "comparison failed")
|
|
)
|
|
),
|
|
search_for_version(Info, Params, ModuleInfo, Request,
|
|
Versions, MaybeMatch2, Match)
|
|
)
|
|
else
|
|
search_for_version(Info, Params, ModuleInfo, Request,
|
|
Versions, MaybeMatch0, 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(ho_params::in, module_info::in, ho_request::in,
|
|
new_pred::in, match::out) is semidet.
|
|
|
|
version_matches(Params, ModuleInfo, Request, Version, Match) :-
|
|
Match = match(Version, PartialMatch, Args, ExtraTypeInfoTypes),
|
|
Request = ho_request(_, Callee, ArgsTypes0, _, RequestHigherOrderArgs,
|
|
RequestTVarSet, _, _, _),
|
|
Callee = proc(CalleePredId, _),
|
|
module_info_pred_info(ModuleInfo, CalleePredId, CalleePredInfo),
|
|
Version = new_pred(_, _, _, _, VersionHigherOrderArgs, VersionArgsTypes0,
|
|
VersionExtraTypeInfoTVars, VersionTVarSet, _, _),
|
|
higher_order_args_match(RequestHigherOrderArgs,
|
|
VersionHigherOrderArgs, HigherOrderArgs, FullOrPartial),
|
|
(
|
|
% Don't accept partial matches unless the predicate is imported
|
|
% or we are only doing user-guided type specialization.
|
|
FullOrPartial = match_is_partial,
|
|
PartialMatch = no
|
|
;
|
|
FullOrPartial = match_is_full,
|
|
list.length(HigherOrderArgs, NumHOArgs),
|
|
PartialMatch = yes(NumHOArgs),
|
|
pred_info_get_markers(CalleePredInfo, Markers),
|
|
|
|
% Always fully specialize calls to class methods.
|
|
not check_marker(Markers, marker_class_method),
|
|
not check_marker(Markers, marker_class_instance_method),
|
|
(
|
|
Params ^ param_do_type_spec = do_not_spec_types
|
|
;
|
|
pred_info_is_imported(CalleePredInfo)
|
|
)
|
|
),
|
|
|
|
% Rename apart type variables.
|
|
tvarset_merge_renaming(RequestTVarSet, VersionTVarSet, _, TVarRenaming),
|
|
assoc_list.values(VersionArgsTypes0, VersionArgTypes0),
|
|
apply_variable_renaming_to_type_list(TVarRenaming,
|
|
VersionArgTypes0, VersionArgTypes),
|
|
assoc_list.keys_and_values(ArgsTypes0, Args0, ArgTypes),
|
|
type_list_subsumes(VersionArgTypes, ArgTypes, TypeSubn),
|
|
|
|
% Work out the types of the extra type-info variables that
|
|
% need to be passed to the specialized version.
|
|
%
|
|
% XXX kind inference:
|
|
% we assume all tvars have kind `star'
|
|
|
|
map.init(KindMap),
|
|
apply_variable_renaming_to_tvar_kind_map(TVarRenaming, KindMap,
|
|
RenamedKindMap),
|
|
apply_variable_renaming_to_tvar_list(TVarRenaming,
|
|
VersionExtraTypeInfoTVars, ExtraTypeInfoTVars0),
|
|
apply_rec_subst_to_tvar_list(RenamedKindMap, TypeSubn, ExtraTypeInfoTVars0,
|
|
ExtraTypeInfoTypes),
|
|
get_extra_arguments(HigherOrderArgs, Args0, Args).
|
|
|
|
:- type match_is_full
|
|
---> match_is_full
|
|
; match_is_partial.
|
|
|
|
:- pred higher_order_args_match(list(higher_order_arg)::in,
|
|
list(higher_order_arg)::in, list(higher_order_arg)::out,
|
|
match_is_full::out) is semidet.
|
|
|
|
higher_order_args_match([], [], [], match_is_full).
|
|
higher_order_args_match(RequestArgs, [], [], match_is_partial) :-
|
|
RequestArgs = [_ | _],
|
|
not (
|
|
list.member(RequestArg, RequestArgs),
|
|
RequestConsId = RequestArg ^ hoa_cons_id,
|
|
RequestConsId = closure_cons(_, _)
|
|
).
|
|
higher_order_args_match([RequestArg | RequestArgs], [VersionArg | VersionArgs],
|
|
Args, FullOrPartial) :-
|
|
RequestArg = higher_order_arg(ConsId1, ArgNo1, _, _, _, _, _,
|
|
RequestIsConst),
|
|
VersionArg = higher_order_arg(ConsId2, ArgNo2, _, _, _, _, _,
|
|
VersionIsConst),
|
|
|
|
( if ArgNo1 = ArgNo2 then
|
|
ConsId1 = ConsId2,
|
|
RequestArg = higher_order_arg(_, _, NumArgs, CurriedArgs,
|
|
CurriedArgTypes, CurriedArgRttiInfo, HOCurriedRequestArgs, _),
|
|
VersionArg = higher_order_arg(_, _, NumArgs,
|
|
_, _, _, HOCurriedVersionArgs, _),
|
|
higher_order_args_match(HOCurriedRequestArgs, HOCurriedVersionArgs,
|
|
NewHOCurriedArgs, FullOrPartial),
|
|
higher_order_args_match(RequestArgs, VersionArgs, TailArgs, _),
|
|
NewRequestArg = higher_order_arg(ConsId1, ArgNo1, NumArgs,
|
|
CurriedArgs, CurriedArgTypes, CurriedArgRttiInfo,
|
|
NewHOCurriedArgs, RequestIsConst `and` VersionIsConst),
|
|
Args = [NewRequestArg | TailArgs]
|
|
else
|
|
% 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 \= closure_cons(_, _),
|
|
higher_order_args_match(RequestArgs, [VersionArg | VersionArgs],
|
|
Args, _),
|
|
FullOrPartial = match_is_partial
|
|
).
|
|
|
|
% 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(HOArgs, Args0, ExtraArgs ++ Args) :-
|
|
get_extra_arguments_2(HOArgs, ExtraArgs),
|
|
remove_const_higher_order_args(1, Args0, HOArgs, Args).
|
|
|
|
:- pred get_extra_arguments_2(list(higher_order_arg)::in, list(prog_var)::out)
|
|
is det.
|
|
|
|
get_extra_arguments_2([], []).
|
|
get_extra_arguments_2([HOArg | HOArgs], Args) :-
|
|
HOArg = higher_order_arg(_, _, _, CurriedArgs0, _, _, HOCurriedArgs,
|
|
IsConst),
|
|
(
|
|
IsConst = yes,
|
|
% If this argument is constant, all its sub-terms must be constant,
|
|
% so there won't be anything more to add.
|
|
get_extra_arguments_2(HOArgs, Args)
|
|
;
|
|
IsConst = no,
|
|
remove_const_higher_order_args(1, CurriedArgs0,
|
|
HOCurriedArgs, CurriedArgs),
|
|
get_extra_arguments_2(HOCurriedArgs, ExtraCurriedArgs),
|
|
get_extra_arguments_2(HOArgs, Args1),
|
|
list.condense([CurriedArgs, ExtraCurriedArgs, 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 the left argument.
|
|
%
|
|
:- pred maybe_add_alias(prog_var::in, prog_var::in,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
maybe_add_alias(LVar, RVar, !Info) :-
|
|
KnownVarMap0 = !.Info ^ hoi_known_var_map,
|
|
( if map.search(KnownVarMap0, RVar, KnownConst) then
|
|
map.det_insert(LVar, KnownConst, KnownVarMap0, KnownVarMap),
|
|
!Info ^ hoi_known_var_map := KnownVarMap
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred update_changed_status(ho_changed::in, ho_changed::in, ho_changed::out)
|
|
is det.
|
|
|
|
update_changed_status(hoc_changed, _, hoc_changed).
|
|
update_changed_status(hoc_request, hoc_changed, hoc_changed).
|
|
update_changed_status(hoc_request, hoc_request, hoc_request).
|
|
update_changed_status(hoc_request, hoc_unchanged, hoc_request).
|
|
update_changed_status(hoc_unchanged, Changed, Changed).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type typeclass_info_manipulator
|
|
---> type_info_from_typeclass_info
|
|
; superclass_from_typeclass_info
|
|
; instance_constraint_from_typeclass_info.
|
|
|
|
% Succeed if the predicate is one of the predicates defined in
|
|
% library/private_builtin.m to extract type_infos or typeclass_infos
|
|
% from typeclass_infos.
|
|
%
|
|
:- pred is_typeclass_info_manipulator(module_info::in, pred_id::in,
|
|
typeclass_info_manipulator::out) is semidet.
|
|
|
|
is_typeclass_info_manipulator(ModuleInfo, PredId, TypeClassManipulator) :-
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
mercury_private_builtin_module = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
(
|
|
PredName = "type_info_from_typeclass_info",
|
|
TypeClassManipulator = type_info_from_typeclass_info
|
|
;
|
|
PredName = "superclass_from_typeclass_info",
|
|
TypeClassManipulator = superclass_from_typeclass_info
|
|
;
|
|
PredName = "instance_constraint_from_typeclass_info",
|
|
TypeClassManipulator = instance_constraint_from_typeclass_info
|
|
).
|
|
|
|
% 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(Manipulator, Args, Goal0, Goal, !Info) :-
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
KnownVarMap0 = !.Info ^ hoi_known_var_map,
|
|
( if
|
|
Args = [TypeClassInfoVar, IndexVar, OutputVar],
|
|
map.search(KnownVarMap0, TypeClassInfoVar,
|
|
known_const(TypeClassInfoConsId, TypeClassInfoArgs)),
|
|
find_typeclass_info_components(ModuleInfo, KnownVarMap0,
|
|
TypeClassInfoConsId, TypeClassInfoArgs,
|
|
_ModuleName, ClassId, InstanceNum, _Instance, OtherArgs),
|
|
|
|
map.search(KnownVarMap0, IndexVar, IndexMaybeConst),
|
|
IndexMaybeConst = known_const(some_int_const(int_const(Index0)), [])
|
|
then
|
|
(
|
|
( Manipulator = type_info_from_typeclass_info
|
|
; Manipulator = superclass_from_typeclass_info
|
|
),
|
|
% polymorphism.m adds MR_typeclass_info_num_extra_instance_args
|
|
% to the index.
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
map.lookup(InstanceTable, ClassId, InstanceDefns),
|
|
list.det_index1(InstanceDefns, InstanceNum, InstanceDefn),
|
|
num_extra_instance_args(InstanceDefn, NumExtra),
|
|
Index = Index0 + NumExtra
|
|
;
|
|
Manipulator = instance_constraint_from_typeclass_info,
|
|
Index = Index0
|
|
),
|
|
|
|
(
|
|
OtherArgs = tci_arg_vars(OtherVars),
|
|
list.det_index1(OtherVars, Index, SelectedArg),
|
|
maybe_add_alias(OutputVar, SelectedArg, !Info),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, ground_inst,
|
|
ground_inst, ground_inst),
|
|
Unification = assign(OutputVar, SelectedArg),
|
|
Goal = unify(OutputVar, rhs_var(SelectedArg), UnifyMode,
|
|
Unification, unify_context(umc_explicit, [])),
|
|
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
proc_info_get_rtti_varmaps(ProcInfo0, RttiVarMaps0),
|
|
rtti_var_info_duplicate_replace(SelectedArg, OutputVar,
|
|
RttiVarMaps0, RttiVarMaps),
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, ProcInfo0, ProcInfo),
|
|
!Info ^ hoi_proc_info := ProcInfo,
|
|
|
|
% Sanity check.
|
|
proc_info_get_var_table(ProcInfo, VarTable),
|
|
lookup_var_type(VarTable, OutputVar, OutputVarType),
|
|
lookup_var_type(VarTable, SelectedArg, SelectedArgType),
|
|
( if OutputVarType = SelectedArgType then
|
|
true
|
|
else
|
|
unexpected($pred, "type mismatch")
|
|
)
|
|
;
|
|
OtherArgs = tci_arg_consts(OtherConstArgs),
|
|
list.det_index1(OtherConstArgs, Index, SelectedConstArg),
|
|
(
|
|
SelectedConstArg = csa_constant(SelectedConsId, _),
|
|
SelectedConstInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(SelectedConsId, [])])
|
|
;
|
|
SelectedConstArg = csa_const_struct(SelectedConstNum),
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
lookup_const_struct_num(ConstStructDb, SelectedConstNum,
|
|
SelectedConstStruct),
|
|
SelectedConstStruct = const_struct(SelectedConstConsId, _, _,
|
|
SelectedConstInst, _),
|
|
( if
|
|
( SelectedConstConsId = type_info_cell_constructor(_)
|
|
; SelectedConstConsId = type_info_const(_)
|
|
)
|
|
then
|
|
SelectedConsId = type_info_const(SelectedConstNum)
|
|
else if
|
|
( SelectedConstConsId = typeclass_info_cell_constructor
|
|
; SelectedConstConsId = typeclass_info_const(_)
|
|
)
|
|
then
|
|
SelectedConsId = typeclass_info_const(SelectedConstNum)
|
|
else
|
|
unexpected($pred, "bad SelectedConstStructConsId")
|
|
)
|
|
),
|
|
map.det_insert(OutputVar, known_const(SelectedConsId, []),
|
|
KnownVarMap0, KnownVarMap),
|
|
!Info ^ hoi_known_var_map := KnownVarMap,
|
|
|
|
SelectedConsIdRHS =
|
|
rhs_functor(SelectedConsId, is_not_exist_constr, []),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, SelectedConstInst,
|
|
SelectedConstInst, SelectedConstInst),
|
|
Unification = construct(OutputVar, SelectedConsId, [], [],
|
|
construct_dynamically, cell_is_shared, no_construct_sub_info),
|
|
Goal = unify(OutputVar, SelectedConsIdRHS, UnifyMode,
|
|
Unification, unify_context(umc_explicit, []))
|
|
% XXX do we need to update the rtti varmaps?
|
|
),
|
|
!Info ^ hoi_changed := hoc_changed
|
|
else
|
|
Goal = Goal0
|
|
).
|
|
|
|
:- type type_class_info_args
|
|
---> tci_arg_vars(list(prog_var))
|
|
; tci_arg_consts(list(const_struct_arg)).
|
|
|
|
:- pred find_typeclass_info_components(module_info::in, known_var_map::in,
|
|
cons_id::in, list(prog_var)::in,
|
|
module_name::out, class_id::out, int::out, string::out,
|
|
type_class_info_args::out) is semidet.
|
|
|
|
find_typeclass_info_components(ModuleInfo, KnownVarMap,
|
|
TypeClassInfoConsId, TypeClassInfoArgs,
|
|
ModuleName, ClassId, InstanceNum, Instance, Args) :-
|
|
(
|
|
TypeClassInfoConsId = typeclass_info_cell_constructor,
|
|
% Extract the number of class constraints on the instance
|
|
% from the base_typeclass_info.
|
|
% If we have a variable for the base typeclass info,
|
|
% it cannot be bound to a constant structure, since
|
|
% as far as the HLDS is concerned, a base typeclass info
|
|
% is just a bare cons_id, and not a structure that needs a cell
|
|
% on the heap.
|
|
TypeClassInfoArgs = [BaseTypeClassInfoVar | OtherVars],
|
|
|
|
map.search(KnownVarMap, BaseTypeClassInfoVar,
|
|
BaseTypeClassInfoMaybeConst),
|
|
BaseTypeClassInfoMaybeConst = known_const(BaseTypeClassInfoConsId, _),
|
|
Args = tci_arg_vars(OtherVars)
|
|
;
|
|
TypeClassInfoConsId = typeclass_info_const(TCIConstNum),
|
|
TypeClassInfoArgs = [],
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
lookup_const_struct_num(ConstStructDb, TCIConstNum, TCIConstStruct),
|
|
TCIConstStruct = const_struct(TCIConstConsId, TCIConstArgs, _, _, _),
|
|
expect(unify(TCIConstConsId, typeclass_info_cell_constructor), $pred,
|
|
"TCIConstConsId != typeclass_info_cell_constructor"),
|
|
TCIConstArgs = [BaseTypeClassInfoConstArg | OtherConstArgs],
|
|
BaseTypeClassInfoConstArg = csa_constant(BaseTypeClassInfoConsId, _),
|
|
Args = tci_arg_consts(OtherConstArgs)
|
|
),
|
|
BaseTypeClassInfoConsId =
|
|
base_typeclass_info_const(ModuleName, ClassId, InstanceNum, Instance).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Succeed if the called pred is "unify" or "compare" and is specializable,
|
|
% returning a specialized goal.
|
|
%
|
|
:- pred specialize_special_pred(pred_id::in, proc_id::in, list(prog_var)::in,
|
|
maybe(call_unify_context)::in, hlds_goal_info::in, hlds_goal_expr::out,
|
|
higher_order_info::in, higher_order_info::out) is semidet.
|
|
|
|
specialize_special_pred(CalledPred, CalledProc, Args, MaybeContext,
|
|
OrigGoalInfo, Goal, !Info) :-
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
KnownVarMap = !.Info ^ hoi_known_var_map,
|
|
proc_info_get_var_table(ProcInfo0, VarTable),
|
|
module_info_pred_info(ModuleInfo, CalledPred, CalledPredInfo),
|
|
mercury_public_builtin_module = pred_info_module(CalledPredInfo),
|
|
pred_info_module(CalledPredInfo) = mercury_public_builtin_module,
|
|
PredName = pred_info_name(CalledPredInfo),
|
|
PredArity = pred_info_orig_arity(CalledPredInfo),
|
|
special_pred_name_arity(SpecialId, PredName, _, PredArity),
|
|
special_pred_get_type(SpecialId, Args, Var),
|
|
lookup_var_type(VarTable, Var, Type),
|
|
Type \= type_variable(_, _),
|
|
% Don't specialize tuple types -- the code to unify them only exists
|
|
% in the generic unification routine in the runtime.
|
|
% `private_builtin.builtin_unify_tuple/2' and
|
|
% `private_builtin.builtin_compare_tuple/3' always abort. It might be
|
|
% worth inlining complicated unifications of small tuples (or any
|
|
% other small type).
|
|
Type \= tuple_type(_, _),
|
|
|
|
Args = [TypeInfoVar | SpecialPredArgs],
|
|
map.search(KnownVarMap, TypeInfoVar,
|
|
known_const(_TypeInfoConsId, TypeInfoVarArgs)),
|
|
type_to_ctor(Type, TypeCtor),
|
|
TypeCtor = type_ctor(_, TypeArity),
|
|
( if TypeArity = 0 then
|
|
TypeInfoArgs = []
|
|
else
|
|
TypeInfoVarArgs = [_TypeCtorInfo | TypeInfoArgs]
|
|
),
|
|
( if
|
|
not type_has_user_defined_equality_pred(ModuleInfo, Type, _),
|
|
proc_id_to_int(CalledProc, CalledProcInt),
|
|
CalledProcInt = 0,
|
|
(
|
|
SpecialId = spec_pred_unify,
|
|
SpecialPredArgs = [Arg1, Arg2],
|
|
MaybeResult = no
|
|
;
|
|
SpecialId = spec_pred_compare,
|
|
SpecialPredArgs = [Result, Arg1, Arg2],
|
|
MaybeResult = yes(Result)
|
|
)
|
|
then
|
|
( if
|
|
is_type_a_dummy(ModuleInfo, Type) = is_dummy_type
|
|
then
|
|
specialize_unify_or_compare_pred_for_dummy(MaybeResult, Goal,
|
|
!Info)
|
|
else if
|
|
% Look for unification or comparison applied directly to a
|
|
% builtin or atomic type. This needs to be done separately from
|
|
% the case for user-defined types, for two reasons.
|
|
%
|
|
% First, because we want to specialize such calls even if we are
|
|
% not generating any special preds.
|
|
%
|
|
% Second, because the specialized code is different in the two
|
|
% cases: here it is a call to a builtin predicate, perhaps preceded
|
|
% by casts; there it is a call to a compiler-generated predicate.
|
|
|
|
type_is_atomic(ModuleInfo, Type)
|
|
then
|
|
specialize_unify_or_compare_pred_for_atomic(Type, MaybeResult,
|
|
Arg1, Arg2, MaybeContext, OrigGoalInfo, Goal, !Info)
|
|
else if
|
|
% Look for unification or comparison applied to a no-tag type
|
|
% wrapping a builtin or atomic type. This needs to be done to
|
|
% optimize all the map_lookups with keys of type `term.var/1'
|
|
% in the compiler. (:- type var(T) ---> var(int).)
|
|
%
|
|
% This could possibly be better handled by just inlining the
|
|
% unification code, but the compiler doesn't have the code for
|
|
% the comparison or in-in unification procedures for imported
|
|
% types, and unification and comparison may be implemented in
|
|
% C code in the runtime system.
|
|
|
|
type_is_no_tag_type(ModuleInfo, Type, Constructor, WrappedType),
|
|
not type_has_user_defined_equality_pred(ModuleInfo,
|
|
WrappedType, _),
|
|
|
|
% This could be done for non-atomic types, but it would be a bit
|
|
% more complicated because the type-info for the wrapped type
|
|
% would need to be extracted first.
|
|
type_is_atomic(ModuleInfo, WrappedType)
|
|
then
|
|
WrappedTypeIsDummy = is_type_a_dummy(ModuleInfo, WrappedType),
|
|
specialize_unify_or_compare_pred_for_no_tag(Type, WrappedType,
|
|
WrappedTypeIsDummy, Constructor, MaybeResult, Arg1, Arg2,
|
|
MaybeContext, OrigGoalInfo, Goal, !Info)
|
|
else
|
|
maybe_call_type_specific_unify_or_compare(Type, SpecialId,
|
|
TypeInfoArgs, SpecialPredArgs, MaybeContext, Goal, !Info)
|
|
)
|
|
else
|
|
maybe_call_type_specific_unify_or_compare(Type, SpecialId,
|
|
TypeInfoArgs, SpecialPredArgs, MaybeContext, Goal, !Info)
|
|
).
|
|
|
|
:- pred maybe_call_type_specific_unify_or_compare(mer_type::in,
|
|
special_pred_id::in, list(prog_var)::in, list(prog_var)::in,
|
|
maybe(call_unify_context)::in, hlds_goal_expr::out,
|
|
higher_order_info::in, higher_order_info::out) is semidet.
|
|
|
|
maybe_call_type_specific_unify_or_compare(SpecialPredType, SpecialId,
|
|
TypeInfoArgs, SpecialPredArgs, MaybeContext, Goal, !Info) :-
|
|
% We can only specialize unifications and comparisons to call the
|
|
% type-specific unify or compare predicate if we are generating
|
|
% such predicates.
|
|
type_to_ctor_det(SpecialPredType, SpecialPredTypeCtor),
|
|
find_special_proc(SpecialPredTypeCtor, SpecialId, SymName, SpecialPredId,
|
|
SpecialProcId, !Info),
|
|
( if type_is_higher_order(SpecialPredType) then
|
|
% Builtin_*_pred are special cases which don't need the type-info
|
|
% arguments.
|
|
CallArgs = SpecialPredArgs
|
|
else
|
|
CallArgs = TypeInfoArgs ++ SpecialPredArgs
|
|
),
|
|
Goal = plain_call(SpecialPredId, SpecialProcId, CallArgs, not_builtin,
|
|
MaybeContext, SymName).
|
|
|
|
:- pred specialize_unify_or_compare_pred_for_dummy(maybe(prog_var)::in,
|
|
hlds_goal_expr::out, higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
specialize_unify_or_compare_pred_for_dummy(MaybeResult, GoalExpr, !Info) :-
|
|
(
|
|
MaybeResult = no,
|
|
GoalExpr = conj(plain_conj, []) % true
|
|
;
|
|
MaybeResult = yes(ComparisonResult),
|
|
Builtin = mercury_public_builtin_module,
|
|
TypeCtor = type_ctor(qualified(Builtin, "comparison_result"), 0),
|
|
Eq = cons(qualified(mercury_public_builtin_module, "="), 0, TypeCtor),
|
|
make_const_construction(dummy_context, ComparisonResult, Eq, Goal),
|
|
Goal = hlds_goal(GoalExpr, _)
|
|
).
|
|
|
|
:- pred specialize_unify_or_compare_pred_for_atomic(mer_type::in,
|
|
maybe(prog_var)::in, prog_var::in, prog_var::in,
|
|
maybe(call_unify_context)::in, hlds_goal_info::in, hlds_goal_expr::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
specialize_unify_or_compare_pred_for_atomic(SpecialPredType, MaybeResult,
|
|
Arg1, Arg2, MaybeContext, OrigGoalInfo, GoalExpr, !Info) :-
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
(
|
|
MaybeResult = no,
|
|
UnifyMode = unify_modes_li_lf_ri_rf(ground_inst, ground_inst,
|
|
ground_inst, ground_inst),
|
|
GoalExpr = unify(Arg1, rhs_var(Arg2), UnifyMode,
|
|
simple_test(Arg1, Arg2), unify_context(umc_explicit, []))
|
|
;
|
|
MaybeResult = yes(ComparisonResult),
|
|
find_builtin_type_with_equivalent_compare(ModuleInfo,
|
|
SpecialPredType, CompareType, NeedIntCast),
|
|
type_to_ctor_det(CompareType, CompareTypeCtor),
|
|
get_special_proc_det(ModuleInfo, CompareTypeCtor, spec_pred_compare,
|
|
SymName, SpecialPredId, SpecialProcId),
|
|
(
|
|
NeedIntCast = no,
|
|
NewCallArgs = [ComparisonResult, Arg1, Arg2],
|
|
GoalExpr = plain_call(SpecialPredId, SpecialProcId, NewCallArgs,
|
|
not_builtin, MaybeContext, SymName)
|
|
;
|
|
NeedIntCast = yes,
|
|
Context = goal_info_get_context(OrigGoalInfo),
|
|
generate_unsafe_type_cast(Context, CompareType, is_not_dummy_type,
|
|
Arg1, CastArg1, CastGoal1, ProcInfo0, ProcInfo1),
|
|
generate_unsafe_type_cast(Context, CompareType, is_not_dummy_type,
|
|
Arg2, CastArg2, CastGoal2, ProcInfo1, ProcInfo),
|
|
NewCallArgs = [ComparisonResult, CastArg1, CastArg2],
|
|
Call = plain_call(SpecialPredId, SpecialProcId, NewCallArgs,
|
|
not_builtin, MaybeContext, SymName),
|
|
set_of_var.list_to_set([ComparisonResult, Arg1, Arg2], NonLocals),
|
|
InstMapDelta = instmap_delta_bind_var(ComparisonResult),
|
|
Detism = detism_det,
|
|
goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure,
|
|
Context, GoalInfo),
|
|
GoalExpr = conj(plain_conj,
|
|
[CastGoal1, CastGoal2, hlds_goal(Call, GoalInfo)]),
|
|
!Info ^ hoi_proc_info := ProcInfo
|
|
)
|
|
).
|
|
|
|
:- pred specialize_unify_or_compare_pred_for_no_tag(mer_type::in, mer_type::in,
|
|
is_dummy_type::in, sym_name::in, maybe(prog_var)::in,
|
|
prog_var::in, prog_var::in, maybe(call_unify_context)::in,
|
|
hlds_goal_info::in, hlds_goal_expr::out,
|
|
higher_order_info::in, higher_order_info::out) is det.
|
|
|
|
specialize_unify_or_compare_pred_for_no_tag(OuterType, WrappedType,
|
|
WrappedTypeIsDummy, Constructor, MaybeResult, Arg1, Arg2,
|
|
MaybeContext, OrigGoalInfo, GoalExpr, !Info) :-
|
|
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
ProcInfo0 = !.Info ^ hoi_proc_info,
|
|
Context = goal_info_get_context(OrigGoalInfo),
|
|
unwrap_no_tag_arg(OuterType, WrappedType, WrappedTypeIsDummy, Context,
|
|
Constructor, Arg1, UnwrappedArg1, ExtractGoal1, ProcInfo0, ProcInfo1),
|
|
unwrap_no_tag_arg(OuterType, WrappedType, WrappedTypeIsDummy, Context,
|
|
Constructor, Arg2, UnwrappedArg2, ExtractGoal2, ProcInfo1, ProcInfo2),
|
|
set_of_var.list_to_set([UnwrappedArg1, UnwrappedArg2], NonLocals0),
|
|
(
|
|
MaybeResult = no,
|
|
NonLocals = NonLocals0,
|
|
instmap_delta_init_reachable(InstMapDelta),
|
|
Detism = detism_semi,
|
|
UnifyMode = unify_modes_li_lf_ri_rf(ground_inst, ground_inst,
|
|
ground_inst, ground_inst),
|
|
SpecialGoal = unify(UnwrappedArg1, rhs_var(UnwrappedArg2),
|
|
UnifyMode, simple_test(UnwrappedArg1, UnwrappedArg2),
|
|
unify_context(umc_explicit, [])),
|
|
goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure,
|
|
Context, GoalInfo),
|
|
GoalExpr = conj(plain_conj,
|
|
[ExtractGoal1, ExtractGoal2, hlds_goal(SpecialGoal, GoalInfo)]),
|
|
!Info ^ hoi_proc_info := ProcInfo2
|
|
;
|
|
MaybeResult = yes(ComparisonResult),
|
|
set_of_var.insert(ComparisonResult, NonLocals0, NonLocals),
|
|
InstMapDelta = instmap_delta_bind_var(ComparisonResult),
|
|
Detism = detism_det,
|
|
% Build a new call with the unwrapped arguments.
|
|
find_builtin_type_with_equivalent_compare(ModuleInfo, WrappedType,
|
|
CompareType, NeedIntCast),
|
|
type_to_ctor_det(CompareType, CompareTypeCtor),
|
|
get_special_proc_det(ModuleInfo, CompareTypeCtor, spec_pred_compare,
|
|
SymName, SpecialPredId, SpecialProcId),
|
|
(
|
|
NeedIntCast = no,
|
|
NewCallArgs = [ComparisonResult, UnwrappedArg1, UnwrappedArg2],
|
|
SpecialGoal = plain_call(SpecialPredId, SpecialProcId, NewCallArgs,
|
|
not_builtin, MaybeContext, SymName),
|
|
goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure,
|
|
Context, GoalInfo),
|
|
GoalExpr = conj(plain_conj, [ExtractGoal1, ExtractGoal2,
|
|
hlds_goal(SpecialGoal, GoalInfo)]),
|
|
!Info ^ hoi_proc_info := ProcInfo2
|
|
;
|
|
NeedIntCast = yes,
|
|
generate_unsafe_type_cast(Context, CompareType, is_not_dummy_type,
|
|
UnwrappedArg1, CastArg1, CastGoal1, ProcInfo2, ProcInfo3),
|
|
generate_unsafe_type_cast(Context, CompareType, is_not_dummy_type,
|
|
UnwrappedArg2, CastArg2, CastGoal2, ProcInfo3, ProcInfo4),
|
|
NewCallArgs = [ComparisonResult, CastArg1, CastArg2],
|
|
SpecialGoal = plain_call(SpecialPredId, SpecialProcId, NewCallArgs,
|
|
not_builtin, MaybeContext, SymName),
|
|
goal_info_init(NonLocals, InstMapDelta, Detism, purity_pure,
|
|
Context, GoalInfo),
|
|
GoalExpr = conj(plain_conj,
|
|
[ExtractGoal1, CastGoal1, ExtractGoal2, CastGoal2,
|
|
hlds_goal(SpecialGoal, GoalInfo)]),
|
|
!Info ^ hoi_proc_info := ProcInfo4
|
|
)
|
|
).
|
|
|
|
:- pred find_special_proc(type_ctor::in, special_pred_id::in, sym_name::out,
|
|
pred_id::out, proc_id::out,
|
|
higher_order_info::in, higher_order_info::out) is semidet.
|
|
|
|
find_special_proc(TypeCtor, SpecialId, SymName, PredId, ProcId, !Info) :-
|
|
ModuleInfo0 = !.Info ^ hoi_global_info ^ hogi_module_info,
|
|
( if
|
|
get_special_proc(ModuleInfo0, TypeCtor, SpecialId, SymName0,
|
|
PredId0, ProcId0)
|
|
then
|
|
SymName = SymName0,
|
|
PredId = PredId0,
|
|
ProcId = ProcId0
|
|
else
|
|
special_pred_is_generated_lazily(ModuleInfo0, TypeCtor),
|
|
(
|
|
SpecialId = spec_pred_compare,
|
|
add_lazily_generated_compare_pred_decl(TypeCtor, PredId,
|
|
ModuleInfo0, ModuleInfo),
|
|
ProcId = hlds_pred.initial_proc_id
|
|
;
|
|
SpecialId = spec_pred_index,
|
|
% This shouldn't happen. The index predicate should only be called
|
|
% from the compare predicate. If it is called, it shouldn't be
|
|
% generated lazily.
|
|
fail
|
|
;
|
|
SpecialId = spec_pred_unify,
|
|
|
|
% XXX We should only add the declaration, not the body, for the
|
|
% unify pred, but that complicates things if mode analysis is rerun
|
|
% after higher_order.m and requests more unification procedures.
|
|
% In particular, it's difficult to run polymorphism on the new
|
|
% clauses if the predicate's arguments have already had type-infos
|
|
% added. This case shouldn't come up unless an optimization does
|
|
% reordering which requires rescheduling a conjunction.
|
|
|
|
add_lazily_generated_unify_pred(TypeCtor, PredId,
|
|
ModuleInfo0, ModuleInfo),
|
|
hlds_pred.in_in_unification_proc_id(ProcId)
|
|
),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
ModuleName = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
SymName = qualified(ModuleName, Name),
|
|
!Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo
|
|
).
|
|
|
|
:- pred find_builtin_type_with_equivalent_compare(module_info::in,
|
|
mer_type::in, mer_type::out, bool::out) is det.
|
|
|
|
find_builtin_type_with_equivalent_compare(ModuleInfo, Type, EqvType,
|
|
NeedIntCast) :-
|
|
CtorCat = classify_type(ModuleInfo, Type),
|
|
(
|
|
CtorCat = ctor_cat_builtin(_),
|
|
EqvType = Type,
|
|
NeedIntCast = no
|
|
;
|
|
CtorCat = ctor_cat_enum(_),
|
|
construct_type(type_ctor(unqualified("int"), 0), [], EqvType),
|
|
NeedIntCast = yes
|
|
;
|
|
( CtorCat = ctor_cat_builtin_dummy
|
|
; CtorCat = ctor_cat_void
|
|
; CtorCat = ctor_cat_higher_order
|
|
; CtorCat = ctor_cat_tuple
|
|
; CtorCat = ctor_cat_variable
|
|
; CtorCat = ctor_cat_user(_)
|
|
; CtorCat = ctor_cat_system(_)
|
|
),
|
|
unexpected($pred, "bad type")
|
|
).
|
|
|
|
:- pred generate_unsafe_type_cast(prog_context::in,
|
|
mer_type::in, is_dummy_type::in, prog_var::in, prog_var::out,
|
|
hlds_goal::out, proc_info::in, proc_info::out) is det.
|
|
|
|
generate_unsafe_type_cast(Context, ToType, IsDummy, Arg, CastArg, Goal,
|
|
!ProcInfo) :-
|
|
proc_info_create_var_from_type("", ToType, IsDummy, CastArg, !ProcInfo),
|
|
generate_cast(unsafe_type_cast, Arg, CastArg, Context, Goal).
|
|
|
|
:- pred unwrap_no_tag_arg(mer_type::in, mer_type::in, is_dummy_type::in,
|
|
prog_context::in, sym_name::in, prog_var::in, prog_var::out,
|
|
hlds_goal::out, proc_info::in, proc_info::out) is det.
|
|
|
|
unwrap_no_tag_arg(OuterType, WrappedType, IsDummy, Context, Constructor, Arg,
|
|
UnwrappedArg, Goal, !ProcInfo) :-
|
|
proc_info_create_var_from_type("", WrappedType, IsDummy,
|
|
UnwrappedArg, !ProcInfo),
|
|
type_to_ctor_det(OuterType, OuterTypeCtor),
|
|
ConsId = cons(Constructor, 1, OuterTypeCtor),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyModeInOut = unify_modes_li_lf_ri_rf(Ground, Ground, free, Ground),
|
|
ArgModes = [UnifyModeInOut],
|
|
set_of_var.list_to_set([Arg, UnwrappedArg], NonLocals),
|
|
% This will be recomputed later.
|
|
InstMapDelta = instmap_delta_bind_var(UnwrappedArg),
|
|
goal_info_init(NonLocals, InstMapDelta, detism_det, purity_pure, Context,
|
|
GoalInfo),
|
|
Unification = deconstruct(Arg, ConsId, [UnwrappedArg], ArgModes,
|
|
cannot_fail, cannot_cgc),
|
|
GoalExpr = unify(Arg,
|
|
rhs_functor(ConsId, is_not_exist_constr, [UnwrappedArg]),
|
|
UnifyModeInOut, Unification, unify_context(umc_explicit, [])),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Predicates to process requests for specialization, and create any
|
|
% new predicates that are required.
|
|
%
|
|
|
|
% Filter out requests for higher-order specialization for preds which are
|
|
% too large. Maybe we could allow programmers to declare which predicates
|
|
% they want specialized, as with inlining? Don't create specialized
|
|
% versions of specialized versions, since for some fairly contrived
|
|
% examples involving recursively building up lambda expressions,
|
|
% this can create ridiculous numbers of versions.
|
|
%
|
|
:- pred filter_request(maybe(io.text_output_stream)::in,
|
|
higher_order_global_info::in, ho_request::in,
|
|
list(ho_request)::in, list(ho_request)::out,
|
|
list(ho_request)::in, list(ho_request)::out, io::di, io::uo) is det.
|
|
|
|
filter_request(MaybeProgressStream, Info, Request,
|
|
!AcceptedRequests, !LoopRequests, !IO) :-
|
|
ModuleInfo = Info ^ hogi_module_info,
|
|
Request = ho_request(CallingPredProcId, CalledPredProcId, _, _, HOArgs,
|
|
_, _, RequestKind, Context),
|
|
CalledPredProcId = proc(CalledPredId, _),
|
|
module_info_pred_info(ModuleInfo, CalledPredId, PredInfo),
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
PredFormArity = pred_info_pred_form_arity(PredInfo),
|
|
pred_info_get_arg_types(PredInfo, Types),
|
|
ActualArity = arg_list_arity(Types),
|
|
(
|
|
MaybeProgressStream = no
|
|
;
|
|
MaybeProgressStream = yes(ProgressStream),
|
|
write_request(ProgressStream, ModuleInfo, "Request for",
|
|
qualified(PredModule, PredName), PredFormArity, ActualArity,
|
|
no, HOArgs, Context, !IO)
|
|
),
|
|
(
|
|
RequestKind = user_type_spec,
|
|
% Ignore the size limit for user specified specializations.
|
|
maybe_write_string_to_stream(MaybeProgressStream,
|
|
"% request specialized (user-requested specialization)\n", !IO),
|
|
list.cons(Request, !AcceptedRequests)
|
|
;
|
|
RequestKind = non_user_type_spec,
|
|
( if map.search(Info ^ hogi_goal_sizes, CalledPredId, GoalSize0) then
|
|
GoalSize = GoalSize0
|
|
else
|
|
% This can happen for a specialized version.
|
|
GoalSize = 0
|
|
),
|
|
( if
|
|
GoalSize > Info ^ hogi_params ^ param_size_limit
|
|
then
|
|
maybe_write_string_to_stream(MaybeProgressStream,
|
|
"% not specializing (goal too large).\n", !IO)
|
|
else if
|
|
higher_order_args_size(HOArgs) >
|
|
Info ^ hogi_params ^ param_arg_limit
|
|
then
|
|
% If the arguments are too large, we can end up producing a
|
|
% specialized version with massive numbers of arguments, because
|
|
% all of the curried arguments are passed as separate arguments.
|
|
% Without this extras/xml/xml.parse.chars.m takes forever to
|
|
% compile.
|
|
maybe_write_string_to_stream(MaybeProgressStream,
|
|
"% not specializing (args too large).\n", !IO)
|
|
else if
|
|
% To ensure termination of the specialization process, the depth
|
|
% of the higher-order arguments must strictly decrease compared
|
|
% to parents with the same original pred_proc_id.
|
|
VersionInfoMap = Info ^ hogi_version_info,
|
|
( if
|
|
map.search(VersionInfoMap, CalledPredProcId, CalledVersionInfo)
|
|
then
|
|
CalledVersionInfo = version_info(OrigPredProcId, _, _, _)
|
|
else
|
|
OrigPredProcId = CalledPredProcId
|
|
),
|
|
map.search(VersionInfoMap, CallingPredProcId, CallingVersionInfo),
|
|
CallingVersionInfo = version_info(_, _, _, ParentVersions),
|
|
ArgDepth = higher_order_args_depth(HOArgs),
|
|
some [ParentVersion] (
|
|
list.member(ParentVersion, ParentVersions),
|
|
ParentVersion = parent_version_info(OrigPredProcId,
|
|
OldArgDepth),
|
|
ArgDepth >= OldArgDepth
|
|
)
|
|
then
|
|
!:LoopRequests = [Request | !.LoopRequests],
|
|
maybe_write_string_to_stream(MaybeProgressStream,
|
|
"% not specializing (recursive specialization).\n", !IO)
|
|
else
|
|
maybe_write_string_to_stream(MaybeProgressStream,
|
|
"% request specialized.\n", !IO),
|
|
list.cons(Request, !AcceptedRequests)
|
|
)
|
|
).
|
|
|
|
:- pred maybe_create_new_ho_spec_preds(maybe(io.text_output_stream)::in,
|
|
list(ho_request)::in, list(new_pred)::in, list(new_pred)::out,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out,
|
|
higher_order_global_info::in, higher_order_global_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
maybe_create_new_ho_spec_preds(_, [],
|
|
!NewPreds, !PredsToFix, !Info, !IO).
|
|
maybe_create_new_ho_spec_preds(MaybeProgressStream, [Request | Requests],
|
|
!NewPreds, !PredsToFix, !Info, !IO) :-
|
|
Request = ho_request(CallingPredProcId, CalledPredProcId,
|
|
_, _, _, _, _, _, _),
|
|
set.insert(CallingPredProcId, !PredsToFix),
|
|
( if
|
|
% Check that we aren't redoing the same pred.
|
|
% SpecVersions0 are pred_proc_ids of the specialized versions
|
|
% of the current pred.
|
|
NewPredMap = !.Info ^ hogi_new_pred_map,
|
|
map.search(NewPredMap, CalledPredProcId, SpecVersions0),
|
|
set.member(Version, SpecVersions0),
|
|
version_matches(!.Info ^ hogi_params, !.Info ^ hogi_module_info,
|
|
Request, Version, _)
|
|
then
|
|
true
|
|
else
|
|
create_new_ho_spec_pred(MaybeProgressStream, Request, NewPred,
|
|
!Info, !IO),
|
|
!:NewPreds = [NewPred | !.NewPreds]
|
|
),
|
|
maybe_create_new_ho_spec_preds(MaybeProgressStream, Requests,
|
|
!NewPreds, !PredsToFix, !Info, !IO).
|
|
|
|
% If we weren't allowed to create a specialized version because the
|
|
% loop check failed, check whether the version was created for another
|
|
% request for which the loop check succeeded.
|
|
%
|
|
:- pred check_loop_request(higher_order_global_info::in, ho_request::in,
|
|
set(pred_proc_id)::in, set(pred_proc_id)::out) is det.
|
|
|
|
check_loop_request(Info, Request, !PredsToFix) :-
|
|
CallingPredProcId = Request ^ rq_caller,
|
|
CalledPredProcId = Request ^ rq_callee,
|
|
( if
|
|
map.search(Info ^ hogi_new_pred_map, CalledPredProcId, SpecVersions0),
|
|
some [Version] (
|
|
set.member(Version, SpecVersions0),
|
|
version_matches(Info ^ hogi_params, Info ^ hogi_module_info,
|
|
Request, Version, _)
|
|
)
|
|
then
|
|
set.insert(CallingPredProcId, !PredsToFix)
|
|
else
|
|
true
|
|
).
|
|
|
|
% Here we create the pred_info for the new predicate.
|
|
%
|
|
:- pred create_new_ho_spec_pred(maybe(io.text_output_stream)::in,
|
|
ho_request::in, new_pred::out,
|
|
higher_order_global_info::in, higher_order_global_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
create_new_ho_spec_pred(MaybeProgressStream, Request, NewPred, !Info, !IO) :-
|
|
Request = ho_request(CallerPPId, CalleePPId, CallArgsTypes,
|
|
ExtraTypeInfoTVars, HOArgs, CallerTVarSet, TypeInfoLiveness,
|
|
RequestKind, Context),
|
|
CallerPPId = proc(CallerPredId, CallerProcId),
|
|
ModuleInfo0 = !.Info ^ hogi_module_info,
|
|
module_info_pred_proc_info(ModuleInfo0, CalleePPId, PredInfo0, ProcInfo0),
|
|
|
|
Name0 = pred_info_name(PredInfo0),
|
|
PredFormArity = pred_info_pred_form_arity(PredInfo0),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
|
|
PredModuleName = pred_info_module(PredInfo0),
|
|
pred_info_get_arg_types(PredInfo0, ArgTVarSet, ExistQVars, Types),
|
|
|
|
(
|
|
RequestKind = user_type_spec,
|
|
% If this is a user-guided type specialisation, the new name comes from
|
|
% the name and mode number of the requesting predicate. The mode number
|
|
% is included because we want to avoid the creation of more than one
|
|
% predicate with the same name if more than one mode of a predicate
|
|
% is specialized. Since the names of e.g. deep profiling proc_static
|
|
% structures are derived from the names of predicates, duplicate
|
|
% predicate names lead to duplicate global variable names and hence to
|
|
% link errors.
|
|
CallerPredName0 = predicate_name(ModuleInfo0, CallerPredId),
|
|
|
|
% The higher_order_arg_order_version part is to avoid segmentation
|
|
% faults or other errors when the order or number of extra arguments
|
|
% changes. If the user does not recompile all affected code, the
|
|
% program will not link.
|
|
Transform = tn_user_type_spec(PredOrFunc, CallerPredId, CallerProcId,
|
|
higher_order_arg_order_version),
|
|
make_transformed_pred_name(CallerPredName0, Transform, SpecName),
|
|
ProcTransform =
|
|
proc_transform_user_type_spec(CallerPredId, CallerProcId),
|
|
NewProcId = CallerProcId,
|
|
% 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_get_status(PredInfo0, PredStatus)
|
|
;
|
|
RequestKind = non_user_type_spec,
|
|
NewProcId = hlds_pred.initial_proc_id,
|
|
SeqNumCounter0 = !.Info ^ hogi_next_id,
|
|
counter.allocate(SeqNum, SeqNumCounter0, SeqNumCounter),
|
|
!Info ^ hogi_next_id := SeqNumCounter,
|
|
Transform = tn_higher_order(PredOrFunc, SeqNum),
|
|
make_transformed_pred_name(Name0, Transform, SpecName),
|
|
ProcTransform = proc_transform_higher_order_spec(SeqNum),
|
|
PredStatus = pred_status(status_local)
|
|
),
|
|
|
|
(
|
|
MaybeProgressStream = no
|
|
;
|
|
MaybeProgressStream = yes(ProgressStream),
|
|
ActualArity = arg_list_arity(Types),
|
|
write_request(ProgressStream, ModuleInfo0, "Specializing",
|
|
qualified(PredModuleName, Name0), PredFormArity, ActualArity,
|
|
yes(SpecName), HOArgs, Context, !IO)
|
|
),
|
|
|
|
pred_info_get_origin(PredInfo0, OrigOrigin),
|
|
pred_info_get_typevarset(PredInfo0, TypeVarSet),
|
|
pred_info_get_markers(PredInfo0, MarkerList),
|
|
pred_info_get_goal_type(PredInfo0, GoalType),
|
|
pred_info_get_class_context(PredInfo0, ClassContext),
|
|
pred_info_get_var_name_remap(PredInfo0, VarNameRemap),
|
|
|
|
InitTypes = cit_no_types(pred_form_arity(list.length(CallArgsTypes))),
|
|
ItemNumbers = init_clause_item_numbers_comp_gen,
|
|
clauses_info_init(pf_predicate, InitTypes, ItemNumbers, ClausesInfo0),
|
|
varset.init(EmptyVarSet),
|
|
vars_types_to_var_table(ModuleInfo0, EmptyVarSet, CallArgsTypes, VarTable),
|
|
clauses_info_set_var_table(VarTable, ClausesInfo0, ClausesInfo),
|
|
|
|
CalleePPId = proc(CalleePredId, CalleeProcId),
|
|
Origin = origin_proc_transform(ProcTransform, OrigOrigin,
|
|
CalleePredId, CalleeProcId),
|
|
CurUserDecl = maybe.no,
|
|
map.init(EmptyProofs),
|
|
map.init(EmptyConstraintMap),
|
|
pred_info_init(PredOrFunc, PredModuleName, SpecName, PredFormArity,
|
|
Context, Origin, PredStatus, CurUserDecl, GoalType, MarkerList, Types,
|
|
ArgTVarSet, ExistQVars, ClassContext, EmptyProofs, EmptyConstraintMap,
|
|
ClausesInfo, VarNameRemap, NewPredInfo0),
|
|
pred_info_set_typevarset(TypeVarSet, NewPredInfo0, NewPredInfo1),
|
|
|
|
module_info_get_predicate_table(ModuleInfo0, PredTable0),
|
|
predicate_table_insert(NewPredInfo1, NewPredId, PredTable0, PredTable),
|
|
module_info_set_predicate_table(PredTable, ModuleInfo0, ModuleInfo1),
|
|
|
|
!Info ^ hogi_module_info := ModuleInfo1,
|
|
|
|
SpecSymName = qualified(PredModuleName, SpecName),
|
|
NewPred = new_pred(proc(NewPredId, NewProcId), CalleePPId, CallerPPId,
|
|
SpecSymName, HOArgs, CallArgsTypes, ExtraTypeInfoTVars, CallerTVarSet,
|
|
TypeInfoLiveness, RequestKind),
|
|
|
|
higher_order_add_new_pred(CalleePPId, NewPred, !Info),
|
|
|
|
create_new_proc(NewPred, ProcInfo0, NewPredInfo1, NewPredInfo, !Info),
|
|
ModuleInfo2 = !.Info ^ hogi_module_info,
|
|
module_info_set_pred_info(NewPredId, NewPredInfo, ModuleInfo2, ModuleInfo),
|
|
!Info ^ hogi_module_info := ModuleInfo.
|
|
|
|
:- pred higher_order_add_new_pred(pred_proc_id::in, new_pred::in,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
higher_order_add_new_pred(CalleePPId, NewPred, !Info) :-
|
|
NewPredMap0 = !.Info ^ hogi_new_pred_map,
|
|
( if map.search(NewPredMap0, CalleePPId, SpecVersions0) then
|
|
set.insert(NewPred, SpecVersions0, SpecVersions),
|
|
map.det_update(CalleePPId, SpecVersions, NewPredMap0, NewPredMap)
|
|
else
|
|
SpecVersions = set.make_singleton_set(NewPred),
|
|
map.det_insert(CalleePPId, SpecVersions, NewPredMap0, NewPredMap)
|
|
),
|
|
!Info ^ hogi_new_pred_map := NewPredMap.
|
|
|
|
:- pred write_request(io.text_output_stream::in, module_info::in,
|
|
string::in, sym_name::in, pred_form_arity::in, pred_form_arity::in,
|
|
maybe(string)::in, list(higher_order_arg)::in, prog_context::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_request(OutputStream, ModuleInfo, Msg,
|
|
SymName, PredArity, ActualArity, MaybeNewName, HOArgs, Context, !IO) :-
|
|
OldName = sym_name_to_string(SymName),
|
|
PredArity = pred_form_arity(PredArityInt),
|
|
ActualArity = pred_form_arity(ActualArityInt),
|
|
io.write_string(OutputStream, "% ", !IO),
|
|
prog_out.write_context(OutputStream, Context, !IO),
|
|
io.format(OutputStream, "%s `%s'/%d",
|
|
[s(Msg), s(OldName), i(PredArityInt)], !IO),
|
|
(
|
|
MaybeNewName = yes(NewName),
|
|
io.format(OutputStream, " into %s", [s(NewName)], !IO)
|
|
;
|
|
MaybeNewName = no
|
|
),
|
|
io.write_string(OutputStream, " with higher-order arguments:\n", !IO),
|
|
NumToDrop = ActualArityInt - PredArityInt,
|
|
output_higher_order_args(OutputStream, ModuleInfo, NumToDrop, 0,
|
|
HOArgs, !IO).
|
|
|
|
:- pred output_higher_order_args(io.text_output_stream::in, module_info::in,
|
|
int::in, int::in, list(higher_order_arg)::in, io::di, io::uo) is det.
|
|
|
|
output_higher_order_args(_, _, _, _, [], !IO).
|
|
output_higher_order_args(OutputStream, ModuleInfo, NumToDrop, Indent,
|
|
[HOArg | HOArgs], !IO) :-
|
|
HOArg = higher_order_arg(ConsId, ArgNo, NumArgs, _, _, _,
|
|
CurriedHOArgs, IsConst),
|
|
io.write_string(OutputStream, "% ", !IO),
|
|
list.duplicate(Indent + 1, " ", Spaces),
|
|
list.foldl(io.write_string(OutputStream), Spaces, !IO),
|
|
(
|
|
IsConst = yes,
|
|
io.write_string(OutputStream, "const ", !IO)
|
|
;
|
|
IsConst = no
|
|
),
|
|
( if ConsId = closure_cons(ShroudedPredProcId, _) then
|
|
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
% Adjust message for type_infos.
|
|
DeclaredArgNo = ArgNo - NumToDrop,
|
|
io.format(OutputStream, "HeadVar__%d = `%s'/%d",
|
|
[i(DeclaredArgNo), s(Name), i(PredArity)], !IO)
|
|
else if ConsId = type_ctor_info_const(TypeModule, TypeName, TypeArity) then
|
|
io.format(OutputStream, "type_ctor_info for `%s'/%d",
|
|
[s(sym_name_to_escaped_string(qualified(TypeModule, TypeName))),
|
|
i(TypeArity)], !IO)
|
|
else if ConsId = base_typeclass_info_const(_, ClassId, _, _) then
|
|
ClassId = class_id(ClassSymName, ClassArity),
|
|
io.format(OutputStream, "base_typeclass_info for `%s'/%d",
|
|
[s(sym_name_to_escaped_string(ClassSymName)), i(ClassArity)], !IO)
|
|
else
|
|
% XXX output the type.
|
|
io.write_string(OutputStream, "type_info/typeclass_info", !IO)
|
|
),
|
|
io.format(OutputStream, " with %d curried arguments", [i(NumArgs)], !IO),
|
|
(
|
|
CurriedHOArgs = [],
|
|
io.nl(OutputStream, !IO)
|
|
;
|
|
CurriedHOArgs = [_ | _],
|
|
io.write_string(OutputStream, ":\n", !IO),
|
|
output_higher_order_args(OutputStream, ModuleInfo, 0, Indent + 1,
|
|
CurriedHOArgs, !IO)
|
|
),
|
|
output_higher_order_args(OutputStream, ModuleInfo, NumToDrop, Indent,
|
|
HOArgs, !IO).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type must_recompute
|
|
---> must_recompute
|
|
; need_not_recompute.
|
|
|
|
:- pred ho_fixup_preds(list(pred_proc_id)::in, higher_order_global_info::in,
|
|
higher_order_global_info::out) is det.
|
|
|
|
ho_fixup_preds(PredProcIds, !Info) :-
|
|
Requests0 = !.Info ^ hogi_requests,
|
|
list.foldl(ho_fixup_pred(need_not_recompute), PredProcIds, !Info),
|
|
% Any additional requests must have already been denied.
|
|
!Info ^ hogi_requests := Requests0.
|
|
|
|
:- pred ho_fixup_specialized_versions(list(new_pred)::in,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
ho_fixup_specialized_versions(NewPredList, !Info) :-
|
|
NewPredProcIds = list.map(get_np_version_ppid, NewPredList),
|
|
% Reprocess the goals to find any new specializations made
|
|
% possible by the specializations performed in this pass.
|
|
list.foldl(ho_fixup_pred(must_recompute), NewPredProcIds, !Info).
|
|
|
|
% Fixup calls to specialized predicates.
|
|
%
|
|
:- pred ho_fixup_pred(must_recompute::in, pred_proc_id::in,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
ho_fixup_pred(MustRecompute, proc(PredId, ProcId), !GlobalInfo) :-
|
|
ho_traverse_proc(MustRecompute, PredId, ProcId, !GlobalInfo).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Build a proc_info for a specialized version.
|
|
%
|
|
:- pred create_new_proc(new_pred::in, proc_info::in,
|
|
pred_info::in, pred_info::out,
|
|
higher_order_global_info::in, higher_order_global_info::out) is det.
|
|
|
|
create_new_proc(NewPred, !.NewProcInfo, !NewPredInfo, !GlobalInfo) :-
|
|
ModuleInfo = !.GlobalInfo ^ hogi_module_info,
|
|
|
|
NewPred = new_pred(NewPredProcId, OldPredProcId, CallerPredProcId, _Name,
|
|
HOArgs0, CallArgsTypes0, ExtraTypeInfoTVars0, _, _, _),
|
|
|
|
proc_info_get_headvars(!.NewProcInfo, HeadVars0),
|
|
proc_info_get_argmodes(!.NewProcInfo, ArgModes0),
|
|
pred_info_get_exist_quant_tvars(!.NewPredInfo, ExistQVars0),
|
|
pred_info_get_typevarset(!.NewPredInfo, TypeVarSet0),
|
|
pred_info_get_tvar_kind_map(!.NewPredInfo, KindMap0),
|
|
pred_info_get_arg_types(!.NewPredInfo, OriginalArgTypes0),
|
|
|
|
CallerPredProcId = proc(CallerPredId, _),
|
|
module_info_pred_info(ModuleInfo, CallerPredId, CallerPredInfo),
|
|
pred_info_get_typevarset(CallerPredInfo, CallerTypeVarSet),
|
|
pred_info_get_univ_quant_tvars(CallerPredInfo, CallerHeadParams),
|
|
|
|
% Specialize the types of the called procedure as for inlining.
|
|
proc_info_get_var_table(!.NewProcInfo, VarTable0),
|
|
tvarset_merge_renaming(CallerTypeVarSet, TypeVarSet0, TypeVarSet,
|
|
TypeRenaming),
|
|
apply_variable_renaming_to_tvar_kind_map(TypeRenaming, KindMap0, KindMap),
|
|
apply_variable_renaming_to_var_table(TypeRenaming, VarTable0, VarTable1),
|
|
apply_variable_renaming_to_type_list(TypeRenaming,
|
|
OriginalArgTypes0, OriginalArgTypes1),
|
|
|
|
% The real set of existentially quantified variables may be
|
|
% smaller, but this is OK.
|
|
apply_variable_renaming_to_tvar_list(TypeRenaming,
|
|
ExistQVars0, ExistQVars1),
|
|
|
|
assoc_list.keys_and_values(CallArgsTypes0, CallArgs, CallerArgTypes0),
|
|
compute_caller_callee_type_substitution(OriginalArgTypes1, CallerArgTypes0,
|
|
CallerHeadParams, ExistQVars1, TypeSubn),
|
|
|
|
apply_rec_subst_to_tvar_list(KindMap, TypeSubn, ExistQVars1, ExistQTypes),
|
|
list.filter_map(
|
|
( pred(ExistQType::in, ExistQVar::out) is semidet :-
|
|
ExistQType = type_variable(ExistQVar, _)
|
|
), ExistQTypes, ExistQVars),
|
|
|
|
apply_rec_subst_to_var_table(is_type_a_dummy(ModuleInfo), TypeSubn,
|
|
VarTable1, VarTable2),
|
|
apply_rec_subst_to_type_list(TypeSubn,
|
|
OriginalArgTypes1, OriginalArgTypes),
|
|
proc_info_set_var_table(VarTable2, !NewProcInfo),
|
|
|
|
% XXX kind inference: we assume vars have kind `star'.
|
|
prog_type.var_list_to_type_list(map.init, ExtraTypeInfoTVars0,
|
|
ExtraTypeInfoTVarTypes0),
|
|
( if
|
|
( map.is_empty(TypeSubn)
|
|
; ExistQVars = []
|
|
)
|
|
then
|
|
HOArgs = HOArgs0,
|
|
ExtraTypeInfoTVarTypes = ExtraTypeInfoTVarTypes0,
|
|
ExtraTypeInfoTVars = ExtraTypeInfoTVars0
|
|
else
|
|
% If there are existentially quantified variables in the callee
|
|
% we may need to bind type variables in the caller.
|
|
list.map(substitute_higher_order_arg(TypeSubn), HOArgs0, HOArgs),
|
|
|
|
apply_rec_subst_to_type_list(TypeSubn, ExtraTypeInfoTVarTypes0,
|
|
ExtraTypeInfoTVarTypes),
|
|
% The substitution should never bind any of the type variables
|
|
% for which extra type-infos are needed, otherwise it
|
|
% wouldn't be necessary to add them.
|
|
( if
|
|
prog_type.type_list_to_var_list(ExtraTypeInfoTVarTypes,
|
|
ExtraTypeInfoTVarsPrim)
|
|
then
|
|
ExtraTypeInfoTVars = ExtraTypeInfoTVarsPrim
|
|
else
|
|
unexpected($pred, "type var got bound")
|
|
)
|
|
),
|
|
|
|
% Add in the extra typeinfo vars.
|
|
ExtraTypeInfoTypes =
|
|
list.map(build_type_info_type, ExtraTypeInfoTVarTypes),
|
|
proc_info_create_vars_from_types(ModuleInfo, ExtraTypeInfoTypes,
|
|
ExtraTypeInfoVars, !NewProcInfo),
|
|
|
|
% Add any extra type-infos or typeclass-infos we've added
|
|
% to the typeinfo_varmap and typeclass_info_varmap.
|
|
proc_info_get_rtti_varmaps(!.NewProcInfo, RttiVarMaps0),
|
|
|
|
% The variable renaming doesn't rename variables in the callee.
|
|
map.init(EmptyVarRenaming),
|
|
|
|
apply_substitutions_to_rtti_varmaps(TypeRenaming, TypeSubn,
|
|
EmptyVarRenaming, RttiVarMaps0, RttiVarMaps1),
|
|
|
|
% XXX see below
|
|
|
|
% Add entries in the typeinfo_varmap for the extra type-infos.
|
|
list.foldl_corresponding(rtti_det_insert_type_info_type,
|
|
ExtraTypeInfoVars, ExtraTypeInfoTVarTypes,
|
|
RttiVarMaps1, RttiVarMaps2),
|
|
SetTypeInfoVarLocn =
|
|
( pred(TVar::in, Var::in, !.R::in, !:R::out) is det :-
|
|
Locn = type_info(Var),
|
|
rtti_set_type_info_locn(TVar, Locn, !R)
|
|
),
|
|
list.foldl_corresponding(SetTypeInfoVarLocn,
|
|
ExtraTypeInfoTVars, ExtraTypeInfoVars, RttiVarMaps2, RttiVarMaps),
|
|
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, !NewProcInfo),
|
|
|
|
map.from_corresponding_lists(CallArgs, HeadVars0, VarRenaming0),
|
|
|
|
% Construct the constant input closures within the goal
|
|
% for the called procedure.
|
|
map.init(KnownVarMap0),
|
|
construct_higher_order_terms(ModuleInfo, HeadVars0, ExtraHeadVars,
|
|
ArgModes0, ExtraArgModes, HOArgs, !NewProcInfo,
|
|
VarRenaming0, _, KnownVarMap0, KnownVarMap, ConstGoals),
|
|
|
|
% XXX The substitutions used to be applied to the typeclass_info_varmap
|
|
% here rather than at the XXX above. Any new entries added in the code
|
|
% between these two points should therefore be transformed as well?
|
|
% The new entries come from HOArgs, which have already had TypeSubn
|
|
% applied, but not TypeRenaming. Perhaps this is enough?
|
|
|
|
% Record extra information about this version.
|
|
VersionInfoMap0 = !.GlobalInfo ^ hogi_version_info,
|
|
ArgsDepth = higher_order_args_depth(HOArgs),
|
|
|
|
( if map.search(VersionInfoMap0, OldPredProcId, OldProcVersionInfo) then
|
|
OldProcVersionInfo = version_info(OrigPredProcId, _, _, _)
|
|
else
|
|
OrigPredProcId = OldPredProcId
|
|
),
|
|
|
|
( if map.search(VersionInfoMap0, CallerPredProcId, CallerVersionInfo) then
|
|
CallerVersionInfo = version_info(_, _, _, CallerParentVersions)
|
|
else
|
|
CallerParentVersions = []
|
|
),
|
|
ParentVersions = [parent_version_info(OrigPredProcId, ArgsDepth)
|
|
| CallerParentVersions],
|
|
|
|
VersionInfo = version_info(OrigPredProcId, ArgsDepth,
|
|
KnownVarMap, ParentVersions),
|
|
map.det_insert(NewPredProcId, VersionInfo,
|
|
VersionInfoMap0, VersionInfoMap),
|
|
!GlobalInfo ^ hogi_version_info := VersionInfoMap,
|
|
|
|
% Fix up the argument vars, types and modes.
|
|
in_mode(InMode),
|
|
list.length(ExtraTypeInfoVars, NumTypeInfos),
|
|
list.duplicate(NumTypeInfos, InMode, ExtraTypeInfoModes),
|
|
|
|
remove_const_higher_order_args(1, HeadVars0, HOArgs, HeadVars1),
|
|
remove_const_higher_order_args(1, ArgModes0, HOArgs, ArgModes1),
|
|
list.condense([ExtraTypeInfoVars, ExtraHeadVars, HeadVars1], HeadVars),
|
|
list.condense([ExtraTypeInfoModes, ExtraArgModes, ArgModes1], ArgModes),
|
|
proc_info_set_headvars(HeadVars, !NewProcInfo),
|
|
proc_info_set_argmodes(ArgModes, !NewProcInfo),
|
|
|
|
proc_info_get_goal(!.NewProcInfo, Goal6),
|
|
Goal6 = hlds_goal(_, GoalInfo6),
|
|
goal_to_conj_list(Goal6, GoalList6),
|
|
conj_list_to_goal(ConstGoals ++ GoalList6, GoalInfo6, Goal),
|
|
proc_info_set_goal(Goal, !NewProcInfo),
|
|
|
|
% Remove any imported structure sharing and reuse information for the
|
|
% original procedure as they won't be (directly) applicable.
|
|
proc_info_reset_imported_structure_sharing(!NewProcInfo),
|
|
proc_info_reset_imported_structure_reuse(!NewProcInfo),
|
|
|
|
proc_info_get_var_table(!.NewProcInfo, VarTable7),
|
|
lookup_var_types(VarTable7, ExtraHeadVars, ExtraHeadVarTypes0),
|
|
remove_const_higher_order_args(1, OriginalArgTypes,
|
|
HOArgs, ModifiedOriginalArgTypes),
|
|
list.condense([ExtraTypeInfoTypes, ExtraHeadVarTypes0,
|
|
ModifiedOriginalArgTypes], ArgTypes),
|
|
pred_info_set_arg_types(TypeVarSet, ExistQVars, ArgTypes, !NewPredInfo),
|
|
pred_info_set_typevarset(TypeVarSet, !NewPredInfo),
|
|
|
|
% The types of the headvars in the var_table map in the proc_info may be
|
|
% more specific than the argument types returned by pred_info_argtypes
|
|
% if the procedure body binds some existentially quantified type variables.
|
|
% The types of the extra arguments added by construct_higher_order_terms
|
|
% use the substitution computed based on the result
|
|
% pred_info_get_arg_types. We may need to apply a substitution
|
|
% to the types of the new variables in the var_table in the proc_info.
|
|
%
|
|
% XXX We should apply this substitution to the variable types in any
|
|
% callers of this predicate, which may introduce other opportunities
|
|
% for specialization.
|
|
|
|
(
|
|
ExistQVars = []
|
|
;
|
|
ExistQVars = [_ | _],
|
|
lookup_var_types(VarTable7, HeadVars0, OriginalHeadTypes),
|
|
type_list_subsumes_det(OriginalArgTypes, OriginalHeadTypes,
|
|
ExistentialSubn),
|
|
apply_rec_subst_to_type_list(ExistentialSubn, ExtraHeadVarTypes0,
|
|
ExtraHeadVarTypes),
|
|
assoc_list.from_corresponding_lists(ExtraHeadVars,
|
|
ExtraHeadVarTypes, ExtraHeadVarsAndTypes),
|
|
list.foldl(update_var_types(ModuleInfo), ExtraHeadVarsAndTypes,
|
|
VarTable7, VarTable8),
|
|
proc_info_set_var_table(VarTable8, !NewProcInfo)
|
|
),
|
|
|
|
% Find the new class context.
|
|
proc_info_get_headvars(!.NewProcInfo, ArgVars),
|
|
proc_info_get_rtti_varmaps(!.NewProcInfo, NewRttiVarMaps),
|
|
list.map(rtti_varmaps_var_info(NewRttiVarMaps), ArgVars, ArgVarInfos),
|
|
find_class_context(ModuleInfo, ArgVarInfos, ArgModes, [], [],
|
|
ClassContext),
|
|
pred_info_set_class_context(ClassContext, !NewPredInfo),
|
|
|
|
NewPredProcId = proc(_, NewProcId),
|
|
NewProcs = map.singleton(NewProcId, !.NewProcInfo),
|
|
pred_info_set_proc_table(NewProcs, !NewPredInfo).
|
|
|
|
:- pred update_var_types(module_info::in, pair(prog_var, mer_type)::in,
|
|
var_table::in, var_table::out) is det.
|
|
|
|
update_var_types(ModuleInfo, VarAndType, !VarTable) :-
|
|
VarAndType = Var - Type,
|
|
IsDummy = is_type_a_dummy(ModuleInfo, Type),
|
|
lookup_var_entry(!.VarTable, Var, Entry0),
|
|
Entry0 = vte(Name, _, _),
|
|
Entry = vte(Name, Type, IsDummy),
|
|
update_var_entry(Var, Entry, !VarTable).
|
|
|
|
% Take an original list of headvars and arg_modes and return these
|
|
% with curried arguments added. The old higher-order arguments are
|
|
% left in. They may be needed in calls which could not be
|
|
% specialised. If not, unused_args.m can clean them up.
|
|
%
|
|
% Build the initial known_var_map which records higher-order and
|
|
% type_info constants for a call to ho_traverse_proc_body.
|
|
%
|
|
% Build a var-var renaming from the requesting call's arguments to
|
|
% the headvars of the specialized version.
|
|
%
|
|
% This predicate is recursively applied to all curried higher order
|
|
% arguments of higher order arguments.
|
|
%
|
|
% Update higher_order_arg_order_version if the order or number of
|
|
% the arguments for specialized versions changes.
|
|
%
|
|
:- pred construct_higher_order_terms(module_info::in, list(prog_var)::in,
|
|
list(prog_var)::out, list(mer_mode)::in, list(mer_mode)::out,
|
|
list(higher_order_arg)::in, proc_info::in, proc_info::out,
|
|
map(prog_var, prog_var)::in, map(prog_var, prog_var)::out,
|
|
known_var_map::in, known_var_map::out, list(hlds_goal)::out) is det.
|
|
|
|
construct_higher_order_terms(_, _, [], _, [], [], !ProcInfo, !Renaming,
|
|
!KnownVarMap, []).
|
|
construct_higher_order_terms(ModuleInfo, HeadVars0, NewHeadVars, ArgModes0,
|
|
NewArgModes, [HOArg | HOArgs], !ProcInfo, !Renaming,
|
|
!KnownVarMap, ConstGoals) :-
|
|
HOArg = higher_order_arg(ConsId, Index, NumArgs, CurriedArgs,
|
|
CurriedArgTypes, CurriedArgRttiInfo, CurriedHOArgs, IsConst),
|
|
|
|
list.det_index1(HeadVars0, Index, LVar),
|
|
( if ConsId = closure_cons(ShroudedPredProcId, _) then
|
|
% Add the curried arguments to the procedure's argument list.
|
|
proc(PredId, ProcId) =
|
|
unshroud_pred_proc_id(ShroudedPredProcId),
|
|
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
|
|
CalledPredInfo, CalledProcInfo),
|
|
PredOrFunc = pred_info_is_pred_or_func(CalledPredInfo),
|
|
proc_info_get_argmodes(CalledProcInfo, CalledArgModes),
|
|
list.det_split_list(NumArgs, CalledArgModes,
|
|
CurriedArgModes1, NonCurriedArgModes),
|
|
proc_info_interface_determinism(CalledProcInfo, ProcDetism),
|
|
GroundInstInfo = higher_order(pred_inst_info(PredOrFunc,
|
|
NonCurriedArgModes, arg_reg_types_unset, ProcDetism))
|
|
else
|
|
in_mode(InMode),
|
|
GroundInstInfo = none_or_default_func,
|
|
list.duplicate(NumArgs, InMode, CurriedArgModes1)
|
|
),
|
|
|
|
proc_info_create_vars_from_types(ModuleInfo, CurriedArgTypes,
|
|
CurriedHeadVars1, !ProcInfo),
|
|
|
|
proc_info_get_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
|
|
list.foldl_corresponding(add_rtti_info, CurriedHeadVars1,
|
|
CurriedArgRttiInfo, RttiVarMaps0, RttiVarMaps),
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
|
|
|
|
(
|
|
IsConst = no,
|
|
% Make ho_traverse_proc_body pretend that the input higher-order
|
|
% argument is built using the new arguments as its curried arguments.
|
|
map.det_insert(LVar, known_const(ConsId, CurriedHeadVars1),
|
|
!KnownVarMap)
|
|
;
|
|
IsConst = yes
|
|
),
|
|
|
|
assoc_list.from_corresponding_lists(CurriedArgs, CurriedHeadVars1,
|
|
CurriedRenaming),
|
|
list.foldl(
|
|
( pred(VarPair::in, !.Map::in, !:Map::out) is det :-
|
|
VarPair = Var1 - Var2,
|
|
map.set(Var1, Var2, !Map)
|
|
), CurriedRenaming, !Renaming),
|
|
|
|
% Recursively construct the curried higher-order arguments.
|
|
construct_higher_order_terms(ModuleInfo, CurriedHeadVars1,
|
|
ExtraCurriedHeadVars, CurriedArgModes1, ExtraCurriedArgModes,
|
|
CurriedHOArgs, !ProcInfo, !Renaming, !KnownVarMap,
|
|
CurriedConstGoals),
|
|
|
|
% Construct the rest of the higher-order arguments.
|
|
construct_higher_order_terms(ModuleInfo, HeadVars0, NewHeadVars1,
|
|
ArgModes0, NewArgModes1, HOArgs, !ProcInfo,
|
|
!Renaming, !KnownVarMap, ConstGoals1),
|
|
|
|
(
|
|
IsConst = yes,
|
|
% Build the constant inside the specialized version, so that
|
|
% other constants which include it will be recognized as constant.
|
|
ArgModes = list.map(mode_both_sides_to_unify_mode(ModuleInfo),
|
|
CurriedArgModes1),
|
|
set_of_var.list_to_set(CurriedHeadVars1, ConstNonLocals),
|
|
ConstInst = ground(shared, GroundInstInfo),
|
|
ConstInstMapDelta = instmap_delta_from_assoc_list([LVar - ConstInst]),
|
|
goal_info_init(ConstNonLocals, ConstInstMapDelta, detism_det,
|
|
purity_pure, ConstGoalInfo),
|
|
RHS = rhs_functor(ConsId, is_not_exist_constr, CurriedHeadVars1),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, ConstInst,
|
|
ConstInst, ConstInst),
|
|
ConstGoalExpr = unify(LVar, RHS, UnifyMode,
|
|
construct(LVar, ConsId, CurriedHeadVars1, ArgModes,
|
|
construct_dynamically, cell_is_unique, no_construct_sub_info),
|
|
unify_context(umc_explicit, [])),
|
|
ConstGoal = hlds_goal(ConstGoalExpr, ConstGoalInfo),
|
|
ConstGoals0 = CurriedConstGoals ++ [ConstGoal]
|
|
;
|
|
IsConst = no,
|
|
ConstGoals0 = CurriedConstGoals
|
|
),
|
|
|
|
% Fix up the argument lists.
|
|
remove_const_higher_order_args(1, CurriedHeadVars1, CurriedHOArgs,
|
|
CurriedHeadVars),
|
|
remove_const_higher_order_args(1, CurriedArgModes1, CurriedHOArgs,
|
|
CurriedArgModes),
|
|
list.condense([CurriedHeadVars, ExtraCurriedHeadVars, NewHeadVars1],
|
|
NewHeadVars),
|
|
list.condense([CurriedArgModes, ExtraCurriedArgModes, NewArgModes1],
|
|
NewArgModes),
|
|
ConstGoals = ConstGoals0 ++ ConstGoals1.
|
|
|
|
% Add any new type-infos or typeclass-infos to the rtti_varmaps.
|
|
%
|
|
:- pred add_rtti_info(prog_var::in, rtti_var_info::in,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
add_rtti_info(Var, VarInfo, !RttiVarMaps) :-
|
|
(
|
|
VarInfo = type_info_var(TypeInfoType),
|
|
rtti_det_insert_type_info_type(Var, TypeInfoType, !RttiVarMaps),
|
|
( if TypeInfoType = type_variable(TVar, _) then
|
|
maybe_set_typeinfo_locn(TVar, type_info(Var), !RttiVarMaps)
|
|
else
|
|
true
|
|
)
|
|
;
|
|
VarInfo = typeclass_info_var(Constraint),
|
|
( if rtti_search_typeclass_info_var(!.RttiVarMaps, Constraint, _) then
|
|
true
|
|
else
|
|
rtti_det_insert_typeclass_info_var(Constraint, Var, !RttiVarMaps),
|
|
Constraint = constraint(_ClassName, ConstraintArgTypes),
|
|
list.foldl2(update_type_info_locn(Var), ConstraintArgTypes, 1, _,
|
|
!RttiVarMaps)
|
|
)
|
|
;
|
|
VarInfo = non_rtti_var
|
|
).
|
|
|
|
:- pred update_type_info_locn(prog_var::in, mer_type::in, int::in, int::out,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
update_type_info_locn(Var, ConstraintType, Index, Index + 1, !RttiVarMaps) :-
|
|
(
|
|
ConstraintType = type_variable(ConstraintTVar, _),
|
|
maybe_set_typeinfo_locn(ConstraintTVar,
|
|
typeclass_info(Var, Index), !RttiVarMaps)
|
|
;
|
|
( ConstraintType = defined_type(_, _, _)
|
|
; ConstraintType = builtin_type(_)
|
|
; ConstraintType = tuple_type(_, _)
|
|
; ConstraintType = higher_order_type(_, _, _, _, _)
|
|
; ConstraintType = apply_n_type(_, _, _)
|
|
; ConstraintType = kinded_type(_, _)
|
|
)
|
|
).
|
|
|
|
:- pred maybe_set_typeinfo_locn(tvar::in, type_info_locn::in,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
maybe_set_typeinfo_locn(TVar, Locn, !RttiVarMaps) :-
|
|
( if rtti_search_type_info_locn(!.RttiVarMaps, TVar, _) then
|
|
true
|
|
else
|
|
rtti_det_insert_type_info_locn(TVar, Locn, !RttiVarMaps)
|
|
).
|
|
|
|
:- pred remove_const_higher_order_args(int::in, list(T)::in,
|
|
list(higher_order_arg)::in, list(T)::out) is det.
|
|
|
|
remove_const_higher_order_args(_, [], _, []).
|
|
remove_const_higher_order_args(Index, [Arg | Args0], HOArgs0, Args) :-
|
|
(
|
|
HOArgs0 = [HOArg | HOArgs],
|
|
HOArg = higher_order_arg(_, HOIndex, _, _, _, _, _, IsConst),
|
|
( if HOIndex = Index then
|
|
remove_const_higher_order_args(Index + 1, Args0, HOArgs, Args1),
|
|
(
|
|
IsConst = yes,
|
|
Args = Args1
|
|
;
|
|
IsConst = no,
|
|
Args = [Arg | Args1]
|
|
)
|
|
else if HOIndex > Index then
|
|
remove_const_higher_order_args(Index + 1, Args0, HOArgs0, Args1),
|
|
Args = [Arg | Args1]
|
|
else
|
|
unexpected($pred, "unordered indexes")
|
|
)
|
|
;
|
|
HOArgs0 = [],
|
|
Args = [Arg | Args0]
|
|
).
|
|
|
|
:- func higher_order_arg_order_version = int.
|
|
|
|
higher_order_arg_order_version = 1.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Substitute the types in a higher_order_arg.
|
|
%
|
|
:- pred substitute_higher_order_arg(tsubst::in, higher_order_arg::in,
|
|
higher_order_arg::out) is det.
|
|
|
|
substitute_higher_order_arg(Subn, !HOArg) :-
|
|
CurriedArgTypes0 = !.HOArg ^ hoa_curry_type_in_caller,
|
|
CurriedRttiTypes0 = !.HOArg ^ hoa_curry_rtti_type,
|
|
CurriedHOArgs0 = !.HOArg ^ hoa_known_curry_args,
|
|
apply_rec_subst_to_type_list(Subn, CurriedArgTypes0, CurriedArgTypes),
|
|
list.map(substitute_rtti_var_info(Subn), CurriedRttiTypes0,
|
|
CurriedRttiTypes),
|
|
list.map(substitute_higher_order_arg(Subn), CurriedHOArgs0, CurriedHOArgs),
|
|
!HOArg ^ hoa_curry_type_in_caller := CurriedArgTypes,
|
|
!HOArg ^ hoa_curry_rtti_type := CurriedRttiTypes,
|
|
!HOArg ^ hoa_known_curry_args := CurriedHOArgs.
|
|
|
|
:- pred substitute_rtti_var_info(tsubst::in, rtti_var_info::in,
|
|
rtti_var_info::out) is det.
|
|
|
|
substitute_rtti_var_info(Subn, type_info_var(Type0), type_info_var(Type)) :-
|
|
apply_rec_subst_to_type(Subn, Type0, Type).
|
|
substitute_rtti_var_info(Subn, typeclass_info_var(Constraint0),
|
|
typeclass_info_var(Constraint)) :-
|
|
apply_rec_subst_to_prog_constraint(Subn, Constraint0, Constraint).
|
|
substitute_rtti_var_info(_, non_rtti_var, non_rtti_var).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func higher_order_args_size(list(higher_order_arg)) = int.
|
|
|
|
higher_order_args_size(Args) =
|
|
list.foldl(int.max, list.map(higher_order_arg_size, Args), 0).
|
|
|
|
:- func higher_order_arg_size(higher_order_arg) = int.
|
|
|
|
higher_order_arg_size(HOArg) =
|
|
1 + higher_order_args_size(HOArg ^ hoa_known_curry_args).
|
|
|
|
:- func higher_order_args_depth(list(higher_order_arg)) = int.
|
|
|
|
higher_order_args_depth(Args) =
|
|
list.foldl(int.max, list.map(higher_order_arg_depth, Args), 0).
|
|
|
|
:- func higher_order_arg_depth(higher_order_arg) = int.
|
|
|
|
higher_order_arg_depth(HOArg) =
|
|
1 + higher_order_args_depth(HOArg ^ hoa_known_curry_args).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Collect the list of prog_constraints from the list of argument
|
|
% types. The typeclass_info for universal constraints is input,
|
|
% output for existential constraints.
|
|
%
|
|
:- pred find_class_context(module_info::in, list(rtti_var_info)::in,
|
|
list(mer_mode)::in, list(prog_constraint)::in, list(prog_constraint)::in,
|
|
prog_constraints::out) is det.
|
|
|
|
find_class_context(_, [], [], !.RevUniv, !.RevExist, Constraints) :-
|
|
list.reverse(!.RevUniv, Univ),
|
|
list.reverse(!.RevExist, Exist),
|
|
Constraints = constraints(Univ, Exist).
|
|
find_class_context(_, [], [_ | _], _, _, _) :-
|
|
unexpected($pred, "mismatched list length").
|
|
find_class_context(_, [_ | _], [], _, _, _) :-
|
|
unexpected($pred, "mismatched list length").
|
|
find_class_context(ModuleInfo, [VarInfo | VarInfos], [Mode | Modes],
|
|
!.RevUniv, !.RevExist, Constraints) :-
|
|
(
|
|
VarInfo = typeclass_info_var(Constraint),
|
|
( if mode_is_input(ModuleInfo, Mode) then
|
|
maybe_add_constraint(Constraint, !RevUniv)
|
|
else
|
|
maybe_add_constraint(Constraint, !RevExist)
|
|
)
|
|
;
|
|
VarInfo = type_info_var(_)
|
|
;
|
|
VarInfo = non_rtti_var
|
|
),
|
|
find_class_context(ModuleInfo, VarInfos, Modes, !.RevUniv, !.RevExist,
|
|
Constraints).
|
|
|
|
:- pred maybe_add_constraint(prog_constraint::in,
|
|
list(prog_constraint)::in, list(prog_constraint)::out) is det.
|
|
|
|
maybe_add_constraint(Constraint, !RevConstraints) :-
|
|
% Don't create duplicates.
|
|
( if list.member(Constraint, !.RevConstraints) then
|
|
true
|
|
else
|
|
!:RevConstraints = [Constraint | !.RevConstraints]
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func mode_both_sides_to_unify_mode(module_info, mer_mode) = unify_mode.
|
|
|
|
mode_both_sides_to_unify_mode(ModuleInfo, Mode) = UnifyMode :-
|
|
mode_get_insts(ModuleInfo, Mode, InitInst, FinalInst),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(InitInst, FinalInst,
|
|
InitInst, FinalInst).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module transform_hlds.higher_order.
|
|
%-----------------------------------------------------------------------------%
|