mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 18:03:36 +00:00
b21e9e459a
... and almost all calls to get_error_output_stream. Replace them
with ProgressStreams and ErrorStreams passed down from higher in the
call tree.
Use ProgressStreams, not ErrorStreams, to write out error messages about
any failures of filesystem operations. These are not appropriate to put
into a module's .err file, since they are not about an error in the
Mercury code of the module.
compiler/globals.m:
Delete the predicates that return progress streams, and the mutable
behind them.
compiler/passes_aux.m:
Delete the predicates that return progress streams. Delete the
versions of the progress-message-writing predicates that didn't get
the progress stream from their caller.
compiler/*.m:
Pass around ProgressStreams and/or ErrorStreams explicitly,
as mentioned at the top of log message.
In a few places, don't write out error_specs to ErrorStream,
returning it to be printed by our caller, or its caller etc instead.
In some of those places, this allowed the deletion an existing
ErrorStream argument.
Given that get_{progress,error}_output_stream took a ModuleName input,
deleting some of the calls to those predicates left ModuleName unused.
Delete such unused ModuleNames.
In a few places, change argument orders to conform to our usual
programming style.
Fix too-long lines.
3661 lines
151 KiB
Mathematica
3661 lines
151 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(io.text_output_stream::in,
|
|
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_proc_util.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.instmap.
|
|
:- import_module hlds.make_goal.
|
|
:- 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 hlds.var_table_hlds.
|
|
:- import_module libs.
|
|
:- import_module libs.file_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.indent.
|
|
:- 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.parse_tree_out_misc.
|
|
:- import_module parse_tree.parse_tree_out_sym_name.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_mode.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_construct.
|
|
:- import_module parse_tree.prog_type_scan.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_type_test.
|
|
:- import_module parse_tree.prog_type_unify.
|
|
:- 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(ProgressStream, !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,
|
|
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_all_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(list(hlds_goal)::in, list(hlds_goal)::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,
|
|
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_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),
|
|
pred_info_get_orig_arity(CalledPredInfo,
|
|
pred_form_arity(PredFormArityInt)),
|
|
special_pred_name_arity(SpecialId, PredName, _, PredFormArityInt),
|
|
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),
|
|
parse_tree_out_misc.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),
|
|
Indent1Str = indent2_string(Indent + 1),
|
|
io.format(OutputStream, "%% %s", [s(Indent1Str)], !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),
|
|
pred_info_get_orig_arity(PredInfo, pred_form_arity(PredFormArityInt)),
|
|
% Adjust message for type_infos.
|
|
DeclaredArgNo = ArgNo - NumToDrop,
|
|
io.format(OutputStream, "HeadVar__%d = `%s'/%d",
|
|
[i(DeclaredArgNo), s(Name), i(PredFormArityInt)], !IO)
|
|
else if ConsId = type_ctor_info_const(TypeModule, TypeName, TypeArity) then
|
|
io.format(OutputStream, "type_ctor_info for `%s'/%d",
|
|
[s(escaped_sym_name_to_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(escaped_sym_name_to_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.
|
|
%-----------------------------------------------------------------------------%
|