mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-17 14:57:03 +00:00
df9420c3e6
compiler/hlds_goal.m:
Change the unify_mode structure from
unify_modes_lhs_rhs(from_to_insts(LI, LF), from_to_insts(RI, RF))
to
unify_modes_li_lf_ri_rf(LI, LF, RI, RF)
This requires fewer memory allocations (1 vs 3) and less memory
(4 words vs 6), though the performance improvement is too small
to measure.
It should also require writing fewer function symbols in code.
compiler/instmap.m:
compiler/mode_util.m:
For each utility predicate that works with from_to_insts, provide
a version that works with the separate insts contained in it.
Delete the from_to_insts version if no longer needed.
compiler/prog_mode.m:
Delete utility predicates on from_to_insts that are not needed anymore.
compiler/accumulator.m:
compiler/add_pred.m:
compiler/bytecode_gen.m:
compiler/common.m:
compiler/const_prop.m:
compiler/deep_profiling.m:
compiler/delay_partial_inst.m:
compiler/dep_par_conj.m:
compiler/equiv_type_hlds.m:
compiler/erl_unify_gen.m:
compiler/float_regs.m:
compiler/format_call.m:
compiler/goal_util.m:
compiler/higher_order.m:
compiler/hlds_out_goal.m:
compiler/hlds_out_mode.m:
compiler/interval.m:
compiler/lambda.m:
compiler/lco.m:
compiler/make_goal.m:
compiler/ml_unify_gen_construct.m:
compiler/ml_unify_gen_util.m:
compiler/modecheck_goal.m:
compiler/modecheck_unify.m:
compiler/polymorphism.m:
compiler/proc_requests.m:
compiler/prog_rep.m:
compiler/rbmm.region_transformation.m:
compiler/simplify_goal_call.m:
compiler/simplify_goal_scope.m:
compiler/simplify_goal_switch.m:
compiler/size_prof.m:
compiler/stm_expand.m:
compiler/term_util.m:
compiler/unify_gen_construct.m:
compiler/unify_gen_util.m:
compiler/unused_args.m:
Conform to the changes above.
4910 lines
209 KiB
Mathematica
4910 lines
209 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 1995-2012, 2014 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: polymorphism.m.
|
|
% Main authors: fjh and zs.
|
|
%
|
|
% This module is a pass over the HLDS.
|
|
% It does a syntactic transformation to implement polymorphism, including
|
|
% typeclasses, by passing extra `type_info' and `typeclass_info' arguments.
|
|
% These arguments are structures that contain, amongst other things,
|
|
% higher order predicate terms for the polymorphic procedures or methods.
|
|
%
|
|
% See notes/type_class_transformation.html for a description of the
|
|
% transformation and data structures used to implement type classes.
|
|
%
|
|
% XXX The way the code in this module handles existential type classes
|
|
% and type class constraints is a bit ad hoc, in general; there are
|
|
% definitely parts of this code (marked with XXXs below) that could
|
|
% do with a rewrite to make it more consistent and hence more maintainable.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Transformation of polymorphic code:
|
|
%
|
|
% Every polymorphic predicate is transformed so that it takes one additional
|
|
% argument for every type variable in the predicate's type declaration.
|
|
% The argument gives information about the type, including higher order
|
|
% predicate variables for each of the builtin polymorphic operations
|
|
% (currently unify/2, compare/3).
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Representation of type information:
|
|
%
|
|
% IMPORTANT: ANY CHANGES TO THE DOCUMENTATION HERE MUST BE REFLECTED BY
|
|
% SIMILAR CHANGES TO THE #defines IN "runtime/mercury_type_info.h" AND
|
|
% TO THE TYPE SPECIALIZATION CODE IN "compiler/higher_order.m".
|
|
%
|
|
% Type information is represented using one or two cells. The cell which
|
|
% is always present is the type_ctor_info structure, whose structure is
|
|
% defined in runtime/mercury_type_info.h. The other cell is the type_info
|
|
% structure, laid out like this:
|
|
%
|
|
% word 0 <pointer to the type_ctor_info structure>
|
|
% word 1+ <the type_infos for the type params, at least one>
|
|
%
|
|
% (but see note below for how variable arity types differ)
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Optimization of common case (zero arity types):
|
|
%
|
|
% The type_info structure itself is redundant if the type has no type
|
|
% parameters (i.e. its arity is zero). Therefore if the arity is zero,
|
|
% we pass the address of the type_ctor_info structure directly, instead of
|
|
% wrapping it up in another cell. The runtime system will look at the first
|
|
% field of the cell it is passed. If this field is zero, the cell is a
|
|
% type_ctor_info structure for an arity zero type. If this field is not zero,
|
|
% the cell is a new type_info structure, with the first field being the
|
|
% pointer to the type_ctor_info structure.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Variable arity types:
|
|
%
|
|
% There is a slight variation on this for variable-arity type constructors, of
|
|
% there are exactly three: pred, func and tuple. Typeinfos of these types
|
|
% always have a pointer to the pred/0, func/0 or tuple/0 type_ctor_info,
|
|
% regardless of their true arity, so we store the real arity in the type_info
|
|
% as well.
|
|
%
|
|
% word 0 <pointer to the arity 0 type_ctor_info structure>
|
|
% word 1 <arity of predicate>
|
|
% word 2+ <the type_infos for the type params, if any>
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Sharing type_ctor_info structures:
|
|
%
|
|
% For compilation models that can put code addresses in static ground terms,
|
|
% we can arrange to create one copy of the type_ctor_info structure statically,
|
|
% avoiding the need to create other copies at runtime. For compilation models
|
|
% that cannot put code addresses in static ground terms, there are a couple
|
|
% of things we could do:
|
|
%
|
|
% 1. allocate all cells at runtime.
|
|
% 2. use a shared static type_ctor_info, but initialize its code
|
|
% addresses during startup (that is, during the module
|
|
% initialization code).
|
|
%
|
|
% We use option 2.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Example of transformation:
|
|
%
|
|
% Take the following code as an example, ignoring the requirement for
|
|
% superhomogeneous form for clarity:
|
|
%
|
|
% :- pred p(T1).
|
|
% :- pred q(T2).
|
|
% :- pred r(T3).
|
|
%
|
|
% p(X) :- q([X]), r(0).
|
|
%
|
|
% We add an extra argument for each type variable:
|
|
%
|
|
% :- pred p(type_info(T1), T1).
|
|
% :- pred q(type_info(T2), T2).
|
|
% :- pred r(type_info(T3), T3).
|
|
%
|
|
% We transform the body of p to this:
|
|
%
|
|
% p(TypeInfoT1, X) :-
|
|
% TypeCtorInfoT2 = type_ctor_info(list/1),
|
|
% TypeInfoT2 = type_info(TypeCtorInfoT2, TypeInfoT1),
|
|
% q(TypeInfoT2, [X]),
|
|
% TypeInfoT3 = type_ctor_info(int/0),
|
|
% r(TypeInfoT3, 0).
|
|
%
|
|
% Note that type_ctor_infos are actually generated as references to a
|
|
% single shared type_ctor_info.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% Transformation of code using existentially quantified types:
|
|
%
|
|
% The transformation for existential types is similar to the transformation
|
|
% for universally quantified types, except that the type_infos and
|
|
% type_class_infos have mode `out' rather than mode `in'.
|
|
%
|
|
% The argument passing convention is that the new parameters
|
|
% introduced by this pass are placed in the following order:
|
|
%
|
|
% First the type_infos for unconstrained universally quantified type
|
|
% variables, in the order that the type variables first appear in the
|
|
% argument types;
|
|
%
|
|
% then the type_infos for unconstrained existentially quantified type
|
|
% variables, in the order that the type variables first appear in the
|
|
% argument types;
|
|
%
|
|
% then the typeclass_infos for universally quantified constraints,
|
|
% in the order that the constraints appear in the class context;
|
|
%
|
|
% then the typeclass_infos for existentially quantified constraints,
|
|
% in the order that the constraints appear in the class context;
|
|
%
|
|
% and finally the original arguments of the predicate.
|
|
%
|
|
% Bear in mind that for the purposes of this (and most other) calculations,
|
|
% the return parameter of a function counts as the _last_ argument.
|
|
%
|
|
% The convention for class method implementations is slightly different
|
|
% to match the order that the type_infos and typeclass_infos are passed
|
|
% in by do_call_class_method (in runtime/mercury_ho_call.c):
|
|
%
|
|
% First the type_infos for the unconstrained type variables in the
|
|
% instance declaration, in the order that the type variables first appear
|
|
% in the instance arguments;
|
|
%
|
|
% then the typeclass_infos for the class constraints on the instance
|
|
% declaration, in the order that the constraints appear in the declaration;
|
|
%
|
|
% then the remainder of the arguments as above.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.polymorphism.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.vartypes.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.maybe_error.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module list.
|
|
:- import_module maybe.
|
|
:- import_module term.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Run the polymorphism pass over the whole HLDS.
|
|
%
|
|
:- pred polymorphism_process_module(module_info::in, module_info::out,
|
|
list(pred_id)::out, maybe_safe_to_continue::out, list(error_spec)::out)
|
|
is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Run the polymorphism pass over a single pred. This is used to transform
|
|
% clauses introduced by unify_proc.m for complicated unification predicates
|
|
% for types for which unification predicates are generated lazily.
|
|
%
|
|
% This predicate should be used with caution. polymorphism.m expects that
|
|
% the argument types of called predicates have not been transformed yet.
|
|
% This predicate will not work correctly after the original pass of
|
|
% polymorphism has been run if the predicate to be processed calls
|
|
% any polymorphic predicates which require type_infos or typeclass_infos
|
|
% to be added to the argument list.
|
|
%
|
|
% For backwards compatibility, this predicate also does the tasks
|
|
% that older versions of the polymorphism pass used to do: copying
|
|
% goals from clauses to procedures, and doing the post-copying parts
|
|
% of the polymorphism transformation.
|
|
%
|
|
:- pred polymorphism_process_generated_pred(pred_id::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Add the type_info variables for a complicated unification to
|
|
% the appropriate fields in the unification and the goal_info.
|
|
%
|
|
% Exported for modecheck_unify.m.
|
|
%
|
|
:- pred unification_typeinfos_rtti_varmaps(mer_type::in, rtti_varmaps::in,
|
|
unification::in, unification::out, hlds_goal_info::in, hlds_goal_info::out)
|
|
is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Given a list of types, create a list of variables to hold the type_info
|
|
% for those types, and create a list of goals to initialize those type_info
|
|
% variables to the appropriate type_info structures for the types.
|
|
% Update the varset and vartypes accordingly.
|
|
%
|
|
:- pred polymorphism_make_type_info_vars(list(mer_type)::in, term.context::in,
|
|
list(prog_var)::out, list(hlds_goal)::out, poly_info::in, poly_info::out)
|
|
is det.
|
|
|
|
% Likewise, but for a single type.
|
|
%
|
|
:- pred polymorphism_make_type_info_var(mer_type::in, term.context::in,
|
|
prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type int_or_var
|
|
---> iov_int(int)
|
|
; iov_var(prog_var).
|
|
|
|
% gen_extract_type_info(ModuleInfo, TypeVar, Kind,
|
|
% TypeClassInfoVar, IndexIntOrVar, Context, Goals, TypeInfoVar,
|
|
% !VarSet, !VarTypes, !RttiVarMaps):
|
|
%
|
|
% Generate code to extract a type_info variable from a given slot of a
|
|
% typeclass_info variable, by calling type_info_from_typeclass_info from
|
|
% private_builtin. TypeVar is the type variable to which this type_info
|
|
% variable corresponds. Kind is the kind of the type variable.
|
|
% TypeClassInfoVar is the variable holding the type_class_info.
|
|
% IndexIntOrVar specifies which slot it is. The procedure returns
|
|
% TypeInfoVar, which is a fresh variable holding the type_info,
|
|
% and Goals, which is the code generated to initialize TypeInfoVar.
|
|
% The context of these goals will be Context.
|
|
%
|
|
:- pred gen_extract_type_info(module_info::in, tvar::in, kind::in,
|
|
prog_var::in, int_or_var::in, prog_context::in,
|
|
list(hlds_goal)::out, prog_var::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
:- type poly_info.
|
|
|
|
% Extract some fields from a pred_info and proc_info and use them to
|
|
% create a poly_info, for use by the polymorphism transformation.
|
|
%
|
|
:- pred create_poly_info(module_info::in, pred_info::in,
|
|
proc_info::in, poly_info::out) is det.
|
|
|
|
% Update the fields in a pred_info and proc_info with
|
|
% the values in a poly_info.
|
|
%
|
|
:- pred poly_info_extract(poly_info::in, list(error_spec)::out,
|
|
pred_info::in, pred_info::out, proc_info::in, proc_info::out,
|
|
module_info::out) is det.
|
|
|
|
% Build the type describing the typeclass_info for the
|
|
% given prog_constraint.
|
|
%
|
|
:- pred build_typeclass_info_type(prog_constraint::in, mer_type::out) is det.
|
|
|
|
% Check if a type is the `typeclass_info' type introduced by this pass.
|
|
%
|
|
:- pred type_is_typeclass_info(mer_type::in) is semidet.
|
|
|
|
% Check if a type is either the `type_info' type or the
|
|
% `type_ctor_info' type introduced by this pass.
|
|
%
|
|
:- pred type_is_type_info_or_ctor_type(mer_type::in) is semidet.
|
|
|
|
% Construct the type of the type_info for the given type.
|
|
%
|
|
:- pred build_type_info_type(mer_type::in, mer_type::out) is det.
|
|
|
|
% Convert a higher order pred term to a lambda goal.
|
|
%
|
|
:- pred convert_pred_to_lambda_goal(purity::in, lambda_eval_method::in,
|
|
prog_var::in, pred_id::in, proc_id::in, list(prog_var)::in,
|
|
list(mer_type)::in, unify_context::in, hlds_goal_info::in, context::in,
|
|
module_info::in, maybe1(unify_rhs)::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
|
|
|
|
% fix_undetermined_mode_lambda_goal(ModuleInfo, ProcId, Functor0, Functor)
|
|
%
|
|
% This is called by mode checking when it figures out which mode that a
|
|
% lambda goal converted from a higher order pred term should call.
|
|
% Functor0 must have been produced by `convert_pred_to_lambda_goal'.
|
|
%
|
|
:- pred fix_undetermined_mode_lambda_goal(module_info::in, proc_id::in,
|
|
unify_rhs::in(rhs_lambda_goal),
|
|
maybe1(unify_rhs)::out(maybe1(rhs_lambda_goal))) is det.
|
|
|
|
% init_type_info_var(Type, ArgVars, TypeInfoVar, TypeInfoGoal,
|
|
% !VarSet, !VarTypes) :-
|
|
%
|
|
% Create the unification the constructs the second cell of a type_info
|
|
% for Type. ArgVars should contain the arguments of this unification.
|
|
%
|
|
% This unification WILL lead to the creation of cells on the heap
|
|
% at runtime.
|
|
%
|
|
% The first variable in ArgVars should be bound to the type_ctor_info
|
|
% for Type's principal type constructor. If that type constructor is
|
|
% variable arity, the next variable in ArgVars should be bound to an
|
|
% integer giving Type's actual arity. The remaining variables in
|
|
% ArgVars should be bound to the type_infos or type_ctor_infos giving
|
|
% Type's argument types.
|
|
%
|
|
:- pred init_type_info_var(mer_type::in, list(prog_var)::in,
|
|
maybe(prog_var)::in, prog_var::out, hlds_goal::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
% init_const_type_ctor_info_var(Type, TypeCtor,
|
|
% TypeCtorInfoVar, TypeCtorConsId, TypeCtorInfoGoal,
|
|
% !VarSet, !VarTypes, !RttiVarMaps):
|
|
%
|
|
% Create the unification (returned as TypeCtorInfoGoal) that binds a
|
|
% new variable (returned as TypeCtorInfoVar) to the type_ctor_info
|
|
% representing TypeCtor. This will be the constant represented by
|
|
% TypeCtorConsId.
|
|
%
|
|
% This unification WILL NOT lead to the creation of a cell on the
|
|
% heap at runtime; it will cause TypeCtorInfoVar to refer to the
|
|
% statically allocated type_ctor_info cell for the type, allocated
|
|
% in the module that defines the type.
|
|
%
|
|
% We take Type as input for historical reasons: we record Type as
|
|
% the type whose type constructor TypeCtor is, in the type of
|
|
% TypeCtorInfoVar.
|
|
%
|
|
:- pred init_const_type_ctor_info_var(mer_type::in, type_ctor::in,
|
|
prog_var::out, cons_id::out, hlds_goal::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
:- type type_info_kind
|
|
---> type_info
|
|
; type_ctor_info.
|
|
|
|
:- pred new_type_info_var_raw(mer_type::in, type_info_kind::in,
|
|
prog_var::out, prog_varset::in, prog_varset::out,
|
|
vartypes::in, vartypes::out, rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Do the parts of the polymorphism transformation that need to be done
|
|
% *after* goals have been copied from clauses to procedures.
|
|
%
|
|
:- pred post_copy_polymorphism(list(pred_id)::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.clause_to_proc.
|
|
:- import_module check_hlds.introduce_exists_casts.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.const_struct.
|
|
:- import_module hlds.from_ground_term_util.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_args.
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_code_util.
|
|
:- import_module hlds.instmap.
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.passes_aux.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.quantification.
|
|
:- import_module hlds.status.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.builtin_modules.
|
|
:- import_module mdbcomp.goal_path.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.program_representation.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.builtin_lib_types.
|
|
:- import_module parse_tree.prog_data_foreign.
|
|
:- import_module parse_tree.prog_mode.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.set_of_var.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module io.
|
|
:- import_module map.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This whole section just traverses the module structure.
|
|
% We do two passes, the first to fix up the clauses_info and proc_infos
|
|
% (and in fact everything except the pred_info argtypes), the second to fix up
|
|
% the pred_info argtypes. The reason we need two passes is that the first pass
|
|
% looks at the argtypes of the called predicates, and so we need to make
|
|
% sure we don't muck them up before we have finished the first pass.
|
|
|
|
polymorphism_process_module(!ModuleInfo, ExistsCastPredIds,
|
|
SafeToContinue, Specs) :-
|
|
module_info_get_preds(!.ModuleInfo, Preds0),
|
|
map.keys(Preds0, PredIds0),
|
|
list.foldl3(maybe_polymorphism_process_pred, PredIds0,
|
|
safe_to_continue, SafeToContinue, [], Specs, !ModuleInfo),
|
|
module_info_get_preds(!.ModuleInfo, Preds1),
|
|
map.keys(Preds1, PredIds1),
|
|
list.foldl2(fixup_pred_polymorphism, PredIds1, [], ExistsCastPredIds,
|
|
!ModuleInfo).
|
|
|
|
:- pred maybe_polymorphism_process_pred(pred_id::in,
|
|
maybe_safe_to_continue::in, maybe_safe_to_continue::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
maybe_polymorphism_process_pred(PredId, !SafeToContinue,
|
|
!Specs, !ModuleInfo) :-
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
|
|
( if
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
no_type_info_builtin(PredModule, PredName, PredArity)
|
|
then
|
|
true
|
|
else
|
|
polymorphism_process_pred_msg(PredId, !SafeToContinue,
|
|
!Specs, !ModuleInfo)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred fixup_pred_polymorphism(pred_id::in,
|
|
list(pred_id)::in, list(pred_id)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
fixup_pred_polymorphism(PredId, !ExistsCastPredIds, !ModuleInfo) :-
|
|
% Recompute the arg types by finding the headvars and the var->type mapping
|
|
% (from the clauses_info) and applying the type mapping to the extra
|
|
% headvars to get the new arg types. Note that we are careful to only apply
|
|
% the mapping to the extra head vars, not to the originals, because
|
|
% otherwise we would stuff up the arg types for unification predicates for
|
|
% equivalence types.
|
|
|
|
module_info_get_preds(!.ModuleInfo, PredTable0),
|
|
map.lookup(PredTable0, PredId, PredInfo0),
|
|
pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
|
|
clauses_info_get_vartypes(ClausesInfo0, VarTypes0),
|
|
clauses_info_get_headvars(ClausesInfo0, HeadVars),
|
|
|
|
pred_info_get_arg_types(PredInfo0, TypeVarSet, ExistQVars, ArgTypes0),
|
|
proc_arg_vector_partition_poly_args(HeadVars, ExtraHeadVarList,
|
|
OldHeadVarList),
|
|
|
|
lookup_var_types(VarTypes0, ExtraHeadVarList, ExtraArgTypes),
|
|
ArgTypes = ExtraArgTypes ++ ArgTypes0,
|
|
pred_info_set_arg_types(TypeVarSet, ExistQVars, ArgTypes,
|
|
PredInfo0, PredInfo1),
|
|
|
|
% If the clauses bind some existentially quantified type variables,
|
|
% introduce exists_casts goals for affected head variables, including
|
|
% the new type_info and typeclass_info arguments. Make sure the types
|
|
% of the internal versions of type_infos for those type variables in the
|
|
% variable types map are as specific as possible.
|
|
|
|
( if
|
|
ExistQVars = [_ | _],
|
|
% This can fail for unification procedures of equivalence types.
|
|
lookup_var_types(VarTypes0, OldHeadVarList, OldHeadVarTypes),
|
|
type_list_subsumes(ArgTypes0, OldHeadVarTypes, Subn),
|
|
not map.is_empty(Subn)
|
|
then
|
|
pred_info_set_existq_tvar_binding(Subn, PredInfo1, PredInfo),
|
|
!:ExistsCastPredIds = [PredId | !.ExistsCastPredIds]
|
|
else
|
|
PredInfo = PredInfo1
|
|
),
|
|
|
|
map.det_update(PredId, PredInfo, PredTable0, PredTable),
|
|
module_info_set_preds(PredTable, !ModuleInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_pred_msg(pred_id::in,
|
|
maybe_safe_to_continue::in, maybe_safe_to_continue::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
polymorphism_process_pred_msg(PredId, !SafeToContinue, !Specs, !ModuleInfo) :-
|
|
% Since polymorphism transforms not just the procedures defined
|
|
% in the module being compiled, but also all the procedures in
|
|
% all the imported modules, this message can be printed A LOT,
|
|
% even though it is almost never of interest.
|
|
% That is why we enable it only when requested.
|
|
|
|
trace [compiletime(flag("poly_msgs")), io(!IO)] (
|
|
write_pred_progress_message("% Transforming polymorphism for ",
|
|
PredId, !.ModuleInfo, !IO)
|
|
),
|
|
polymorphism_process_pred(PredId, PredSafeToContinue, !Specs, !ModuleInfo),
|
|
(
|
|
PredSafeToContinue = safe_to_continue
|
|
;
|
|
PredSafeToContinue = unsafe_to_continue,
|
|
!:SafeToContinue = unsafe_to_continue
|
|
).
|
|
|
|
polymorphism_process_generated_pred(PredId, !ModuleInfo) :-
|
|
polymorphism_process_pred(PredId, SafeToContinue, [], Specs, !ModuleInfo),
|
|
expect(unify(Specs, []), $pred,
|
|
"generated pred has errors"),
|
|
expect(unify(SafeToContinue, safe_to_continue), $pred,
|
|
"generated pred has errors"),
|
|
fixup_pred_polymorphism(PredId, [], ExistsPredIds, !ModuleInfo),
|
|
copy_clauses_to_procs_for_pred_in_module_info(PredId, !ModuleInfo),
|
|
list.foldl(introduce_exists_casts_poly, ExistsPredIds, !ModuleInfo).
|
|
|
|
:- mutable(selected_pred, bool, no, ground, [untrailed]).
|
|
:- mutable(level, int, 0, ground, [untrailed]).
|
|
|
|
:- pred polymorphism_process_pred(pred_id::in, maybe_safe_to_continue::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
polymorphism_process_pred(PredId, SafeToContinue, !Specs, !ModuleInfo) :-
|
|
trace [compiletime(flag("debug_poly_caches"))] (
|
|
promise_pure (
|
|
% Replace 99999 with the id of the predicate you want to debug.
|
|
( if pred_id_to_int(PredId) = 99999 then
|
|
impure set_selected_pred(yes)
|
|
else
|
|
true
|
|
)
|
|
)
|
|
),
|
|
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
|
|
|
|
% Run the polymorphism pass over the clauses_info, updating the headvars,
|
|
% goals, varsets, types, etc., and computing some information in the
|
|
% poly_info.
|
|
|
|
pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
|
|
polymorphism_process_clause_info(!.ModuleInfo, PredInfo0,
|
|
ClausesInfo0, ClausesInfo, PolyInfo, ExtraArgModes),
|
|
poly_info_get_module_info(PolyInfo, !:ModuleInfo),
|
|
poly_info_get_const_struct_db(PolyInfo, ConstStructDb),
|
|
module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
|
|
|
|
poly_info_get_typevarset(PolyInfo, TypeVarSet),
|
|
pred_info_set_typevarset(TypeVarSet, PredInfo0, PredInfo1),
|
|
pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
|
|
|
|
poly_info_get_errors(PolyInfo, PredSpecs),
|
|
(
|
|
PredSpecs = [],
|
|
SafeToContinue = safe_to_continue
|
|
;
|
|
PredSpecs = [_ | _],
|
|
SafeToContinue = unsafe_to_continue,
|
|
!:Specs = PredSpecs ++ !.Specs
|
|
),
|
|
|
|
% Do a pass over the proc_infos, updating all the argmodes with
|
|
% modes for the extra arguments.
|
|
pred_info_get_proc_table(PredInfo2, ProcMap0),
|
|
map.map_values_only(add_extra_arg_modes_to_proc(ExtraArgModes),
|
|
ProcMap0, ProcMap),
|
|
pred_info_set_proc_table(ProcMap, PredInfo2, PredInfo),
|
|
|
|
trace [compiletime(flag("debug_poly_caches"))] (
|
|
promise_pure (
|
|
impure set_selected_pred(no)
|
|
)
|
|
),
|
|
|
|
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).
|
|
|
|
:- pred polymorphism_process_clause_info(module_info::in, pred_info::in,
|
|
clauses_info::in, clauses_info::out, poly_info::out,
|
|
poly_arg_vector(mer_mode)::out) is det.
|
|
|
|
polymorphism_process_clause_info(ModuleInfo0, PredInfo0, !ClausesInfo, !:Info,
|
|
ExtraArgModes) :-
|
|
init_poly_info(ModuleInfo0, PredInfo0, !.ClausesInfo, !:Info),
|
|
!.ClausesInfo = clauses_info(_VarSet, ExplicitVarTypes, _TVarNameMap,
|
|
_VarTypes, HeadVars0, ClausesRep0, ItemNumbers,
|
|
_RttiVarMaps, HaveForeignClauses, HadSyntaxErrors),
|
|
|
|
setup_headvars(PredInfo0, HeadVars0, HeadVars,
|
|
ExtraArgModes, UnconstrainedTVars,
|
|
ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars, !Info),
|
|
|
|
get_clause_list_for_replacement(ClausesRep0, Clauses0),
|
|
list.map_foldl(
|
|
polymorphism_process_clause(PredInfo0, HeadVars0, HeadVars,
|
|
UnconstrainedTVars, ExtraTypeInfoHeadVars,
|
|
ExistTypeClassInfoHeadVars),
|
|
Clauses0, Clauses, !Info),
|
|
|
|
% Set the new values of the fields in clauses_info.
|
|
poly_info_get_varset(!.Info, VarSet),
|
|
poly_info_get_var_types(!.Info, VarTypes),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps),
|
|
set_clause_list(Clauses, ClausesRep),
|
|
init_vartypes(TVarNameMap), % This is only used while adding the clauses.
|
|
!:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
|
|
VarTypes, HeadVars, ClausesRep, ItemNumbers,
|
|
RttiVarMaps, HaveForeignClauses, HadSyntaxErrors).
|
|
|
|
:- pred polymorphism_process_clause(pred_info::in,
|
|
proc_arg_vector(prog_var)::in, proc_arg_vector(prog_var)::in,
|
|
list(tvar)::in, list(prog_var)::in, list(prog_var)::in,
|
|
clause::in, clause::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_clause(PredInfo0, OldHeadVars, NewHeadVars,
|
|
UnconstrainedTVars, ExtraTypeInfoHeadVars,
|
|
ExistTypeClassInfoHeadVars, !Clause, !Info) :-
|
|
( if pred_info_is_imported(PredInfo0) then
|
|
true
|
|
else
|
|
Goal0 = !.Clause ^ clause_body,
|
|
|
|
% Process any polymorphic calls inside the goal.
|
|
empty_cache_maps(!Info),
|
|
poly_info_set_num_reuses(0, !Info),
|
|
polymorphism_process_goal(Goal0, Goal1, !Info),
|
|
|
|
% Generate code to construct the typeclass_infos and type_infos
|
|
% for existentially quantified type vars.
|
|
produce_existq_tvars(PredInfo0, OldHeadVars,
|
|
UnconstrainedTVars, ExtraTypeInfoHeadVars,
|
|
ExistTypeClassInfoHeadVars, Goal1, Goal2, !Info),
|
|
|
|
pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
|
|
fixup_quantification(NewHeadVars, ExistQVars, Goal2, Goal, !Info),
|
|
!Clause ^ clause_body := Goal
|
|
).
|
|
|
|
:- pred add_extra_arg_modes_to_proc(poly_arg_vector(mer_mode)::in,
|
|
proc_info::in, proc_info::out) is det.
|
|
|
|
add_extra_arg_modes_to_proc(ExtraArgModes, !ProcInfo) :-
|
|
( if proc_info_is_valid_mode(!.ProcInfo) then
|
|
% Add the ExtraArgModes to the proc_info argmodes.
|
|
% XXX ARGVEC - revisit this when the proc_info uses proc_arg_vectors.
|
|
proc_info_get_argmodes(!.ProcInfo, ArgModes1),
|
|
ExtraArgModesList = poly_arg_vector_to_list(ExtraArgModes),
|
|
ArgModes = ExtraArgModesList ++ ArgModes1,
|
|
proc_info_set_argmodes(ArgModes, !ProcInfo)
|
|
else
|
|
true
|
|
).
|
|
|
|
% XXX document me
|
|
%
|
|
% XXX the following code ought to be rewritten to handle
|
|
% existential/universal type_infos and type_class_infos
|
|
% in a more consistent manner.
|
|
%
|
|
:- pred setup_headvars(pred_info::in, proc_arg_vector(prog_var)::in,
|
|
proc_arg_vector(prog_var)::out, poly_arg_vector(mer_mode)::out,
|
|
list(tvar)::out, list(prog_var)::out, list(prog_var)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
setup_headvars(PredInfo, !HeadVars, ExtraArgModes,
|
|
UnconstrainedTVars, ExtraHeadTypeInfoVars,
|
|
ExistHeadTypeClassInfoVars, !Info) :-
|
|
pred_info_get_origin(PredInfo, Origin),
|
|
ExtraArgModes0 = poly_arg_vector_init : poly_arg_vector(mer_mode),
|
|
(
|
|
Origin = origin_instance_method(_, InstanceMethodConstraints),
|
|
setup_headvars_instance_method(PredInfo,
|
|
InstanceMethodConstraints, !HeadVars,
|
|
UnconstrainedTVars, ExtraHeadTypeInfoVars,
|
|
ExistHeadTypeClassInfoVars,
|
|
ExtraArgModes0, ExtraArgModes, !Info)
|
|
;
|
|
( Origin = origin_special_pred(_, _)
|
|
; Origin = origin_class_method
|
|
; Origin = origin_transformed(_, _, _)
|
|
; Origin = origin_created(_)
|
|
; Origin = origin_assertion(_, _)
|
|
; Origin = origin_lambda(_, _, _)
|
|
; Origin = origin_solver_type(_, _, _)
|
|
; Origin = origin_tabling(_, _)
|
|
; Origin = origin_mutable(_, _, _)
|
|
; Origin = origin_initialise
|
|
; Origin = origin_finalise
|
|
; Origin = origin_user(_)
|
|
),
|
|
pred_info_get_class_context(PredInfo, ClassContext),
|
|
InstanceTVars = [],
|
|
InstanceUnconstrainedTVars = [],
|
|
InstanceUnconstrainedTypeInfoVars = [],
|
|
setup_headvars_2(PredInfo, ClassContext, InstanceTVars,
|
|
InstanceUnconstrainedTVars, InstanceUnconstrainedTypeInfoVars,
|
|
!HeadVars, UnconstrainedTVars,
|
|
ExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars,
|
|
ExtraArgModes0, ExtraArgModes, !Info)
|
|
).
|
|
|
|
% For class method implementations, do_call_class_method takes the
|
|
% type_infos and typeclass_infos from the typeclass_info and pastes them
|
|
% onto the front of the argument list. We need to match that order here.
|
|
%
|
|
:- pred setup_headvars_instance_method(pred_info::in,
|
|
instance_method_constraints::in,
|
|
proc_arg_vector(prog_var)::in, proc_arg_vector(prog_var)::out,
|
|
list(tvar)::out, list(prog_var)::out, list(prog_var)::out,
|
|
poly_arg_vector(mer_mode)::in, poly_arg_vector(mer_mode)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
setup_headvars_instance_method(PredInfo,
|
|
InstanceMethodConstraints, !HeadVars,
|
|
UnconstrainedTVars, ExtraHeadTypeInfoVars,
|
|
ExistHeadTypeClassInfoVars, !ExtraArgModes, !Info) :-
|
|
|
|
InstanceMethodConstraints = instance_method_constraints(_,
|
|
InstanceTypes, InstanceConstraints, ClassContext),
|
|
|
|
type_vars_list(InstanceTypes, InstanceTVars),
|
|
get_unconstrained_tvars(InstanceTVars, InstanceConstraints,
|
|
UnconstrainedInstanceTVars),
|
|
pred_info_get_arg_types(PredInfo, ArgTypeVarSet, _, _),
|
|
make_head_vars(UnconstrainedInstanceTVars,
|
|
ArgTypeVarSet, UnconstrainedInstanceTypeInfoVars, !Info),
|
|
make_typeclass_info_head_vars(do_record_type_info_locns,
|
|
InstanceConstraints, InstanceHeadTypeClassInfoVars, !Info),
|
|
|
|
proc_arg_vector_set_instance_type_infos(UnconstrainedInstanceTypeInfoVars,
|
|
!HeadVars),
|
|
proc_arg_vector_set_instance_typeclass_infos(InstanceHeadTypeClassInfoVars,
|
|
!HeadVars),
|
|
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
list.foldl(rtti_reuse_typeclass_info_var,
|
|
InstanceHeadTypeClassInfoVars, RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
|
|
|
|
in_mode(InMode),
|
|
list.duplicate(list.length(UnconstrainedInstanceTypeInfoVars),
|
|
InMode, UnconstrainedInstanceTypeInfoModes),
|
|
list.duplicate(list.length(InstanceHeadTypeClassInfoVars),
|
|
InMode, InstanceHeadTypeClassInfoModes),
|
|
poly_arg_vector_set_instance_type_infos(
|
|
UnconstrainedInstanceTypeInfoModes, !ExtraArgModes),
|
|
poly_arg_vector_set_instance_typeclass_infos(
|
|
InstanceHeadTypeClassInfoModes, !ExtraArgModes),
|
|
|
|
setup_headvars_2(PredInfo, ClassContext,
|
|
InstanceTVars,
|
|
UnconstrainedInstanceTVars, UnconstrainedInstanceTypeInfoVars,
|
|
!HeadVars,
|
|
UnconstrainedTVars, ExtraHeadTypeInfoVars,
|
|
ExistHeadTypeClassInfoVars, !ExtraArgModes, !Info).
|
|
|
|
:- pred setup_headvars_2(pred_info::in, prog_constraints::in,
|
|
list(tvar)::in, list(tvar)::in, list(prog_var)::in,
|
|
proc_arg_vector(prog_var)::in, proc_arg_vector(prog_var)::out,
|
|
list(tvar)::out, list(prog_var)::out, list(prog_var)::out,
|
|
poly_arg_vector(mer_mode)::in, poly_arg_vector(mer_mode)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
setup_headvars_2(PredInfo, ClassContext,
|
|
InstanceTVars, UnconstrainedInstanceTVars,
|
|
UnconstrainedInstanceTypeInfoVars, HeadVars0,
|
|
HeadVars, AllUnconstrainedTVars,
|
|
AllExtraHeadTypeInfoVars, ExistHeadTypeClassInfoVars,
|
|
!ExtraArgModes, !Info) :-
|
|
|
|
% Grab the appropriate fields from the pred_info.
|
|
pred_info_get_arg_types(PredInfo, ArgTypeVarSet, ExistQVars, ArgTypes),
|
|
|
|
% Insert extra head variables to hold the address of the type_infos
|
|
% and typeclass_infos. We insert one variable for each unconstrained
|
|
% type variable (for the type_info) and one variable for each
|
|
% constraint (for the typeclass_info).
|
|
%
|
|
% The order of these variables is important, and must match the order
|
|
% specified at the top of this file.
|
|
|
|
% Make a fresh variable for each class constraint, returning a list of
|
|
% variables that appear in the constraints, along with the location of
|
|
% the type infos for them. For the existential constraints, we want
|
|
% the rtti_varmaps to contain the internal view of the types (that is,
|
|
% with type variables bound) so we may need to look up the actual
|
|
% constraints in the constraint map. For the universal constraints there
|
|
% is no distinction between the internal views and the external view, so
|
|
% we just use the constraints from the class context.
|
|
ClassContext = constraints(UnivConstraints, ExistConstraints),
|
|
prog_type.constraint_list_get_tvars(UnivConstraints,
|
|
UnivConstrainedTVars),
|
|
prog_type.constraint_list_get_tvars(ExistConstraints,
|
|
ExistConstrainedTVars),
|
|
poly_info_get_constraint_map(!.Info, ConstraintMap),
|
|
get_improved_exists_head_constraints(ConstraintMap, ExistConstraints,
|
|
ActualExistConstraints),
|
|
( if
|
|
pred_info_get_markers(PredInfo, PredMarkers),
|
|
check_marker(PredMarkers, marker_class_method)
|
|
then
|
|
% For class methods we record the type_info_locns even for the
|
|
% existential constraints. It is easier to do it here than when we
|
|
% are expanding class method bodies, and we know there won't be any
|
|
% references to the type_info after the instance method call so
|
|
% recording them now won't be a problem.
|
|
RecordExistQLocns = do_record_type_info_locns
|
|
else
|
|
RecordExistQLocns = do_not_record_type_info_locns
|
|
),
|
|
make_typeclass_info_head_vars(RecordExistQLocns, ActualExistConstraints,
|
|
ExistHeadTypeClassInfoVars, !Info),
|
|
make_typeclass_info_head_vars(do_record_type_info_locns, UnivConstraints,
|
|
UnivHeadTypeClassInfoVars, !Info),
|
|
|
|
type_vars_list(ArgTypes, HeadTypeVars),
|
|
list.delete_elems(HeadTypeVars, UnivConstrainedTVars,
|
|
UnconstrainedTVars0),
|
|
list.delete_elems(UnconstrainedTVars0, ExistConstrainedTVars,
|
|
UnconstrainedTVars1),
|
|
|
|
% Typeinfos for the instance tvars have already been introduced by
|
|
% setup_headvars_instance_method.
|
|
list.delete_elems(UnconstrainedTVars1, InstanceTVars,
|
|
UnconstrainedTVars2),
|
|
list.remove_dups(UnconstrainedTVars2, UnconstrainedTVars),
|
|
|
|
(
|
|
ExistQVars = [],
|
|
% Optimize common case.
|
|
UnconstrainedUnivTVars = UnconstrainedTVars,
|
|
UnconstrainedExistTVars = [],
|
|
ExistHeadTypeInfoVars = []
|
|
;
|
|
ExistQVars = [_ | _],
|
|
list.delete_elems(UnconstrainedTVars, ExistQVars,
|
|
UnconstrainedUnivTVars),
|
|
list.delete_elems(UnconstrainedTVars, UnconstrainedUnivTVars,
|
|
UnconstrainedExistTVars),
|
|
make_head_vars(UnconstrainedExistTVars, ArgTypeVarSet,
|
|
ExistHeadTypeInfoVars, !Info)
|
|
),
|
|
|
|
make_head_vars(UnconstrainedUnivTVars, ArgTypeVarSet,
|
|
UnivHeadTypeInfoVars, !Info),
|
|
ExtraHeadTypeInfoVars = UnivHeadTypeInfoVars ++ ExistHeadTypeInfoVars,
|
|
|
|
AllExtraHeadTypeInfoVars = UnconstrainedInstanceTypeInfoVars
|
|
++ ExtraHeadTypeInfoVars,
|
|
list.condense([UnconstrainedInstanceTVars, UnconstrainedUnivTVars,
|
|
UnconstrainedExistTVars], AllUnconstrainedTVars),
|
|
|
|
proc_arg_vector_set_univ_type_infos(UnivHeadTypeInfoVars,
|
|
HeadVars0, HeadVars1),
|
|
proc_arg_vector_set_exist_type_infos(ExistHeadTypeInfoVars,
|
|
HeadVars1, HeadVars2),
|
|
proc_arg_vector_set_univ_typeclass_infos(UnivHeadTypeClassInfoVars,
|
|
HeadVars2, HeadVars3),
|
|
proc_arg_vector_set_exist_typeclass_infos(ExistHeadTypeClassInfoVars,
|
|
HeadVars3, HeadVars),
|
|
|
|
% Figure out the modes of the introduced type_info and typeclass_info
|
|
% arguments.
|
|
|
|
in_mode(In),
|
|
out_mode(Out),
|
|
list.length(UnconstrainedUnivTVars, NumUnconstrainedUnivTVars),
|
|
list.length(UnconstrainedExistTVars, NumUnconstrainedExistTVars),
|
|
list.length(UnivHeadTypeClassInfoVars, NumUnivClassInfoVars),
|
|
list.length(ExistHeadTypeClassInfoVars, NumExistClassInfoVars),
|
|
list.duplicate(NumUnconstrainedUnivTVars, In, UnivTypeInfoModes),
|
|
list.duplicate(NumUnconstrainedExistTVars, Out, ExistTypeInfoModes),
|
|
list.duplicate(NumUnivClassInfoVars, In, UnivTypeClassInfoModes),
|
|
list.duplicate(NumExistClassInfoVars, Out, ExistTypeClassInfoModes),
|
|
poly_arg_vector_set_univ_type_infos(UnivTypeInfoModes, !ExtraArgModes),
|
|
poly_arg_vector_set_exist_type_infos(ExistTypeInfoModes, !ExtraArgModes),
|
|
poly_arg_vector_set_univ_typeclass_infos(UnivTypeClassInfoModes,
|
|
!ExtraArgModes),
|
|
poly_arg_vector_set_exist_typeclass_infos(ExistTypeClassInfoModes,
|
|
!ExtraArgModes),
|
|
|
|
% Add the locations of the typeinfos for unconstrained, universally
|
|
% quantified type variables to the initial rtti_varmaps. Also add the
|
|
% locations of typeclass_infos.
|
|
%
|
|
some [!RttiVarMaps] (
|
|
poly_info_get_rtti_varmaps(!.Info, !:RttiVarMaps),
|
|
|
|
ToLocn =
|
|
( pred(TheVar::in, TheLocn::out) is det :-
|
|
TheLocn = type_info(TheVar)
|
|
),
|
|
|
|
list.map(ToLocn, UnivHeadTypeInfoVars, UnivTypeLocns),
|
|
list.foldl_corresponding(rtti_det_insert_type_info_locn,
|
|
UnconstrainedUnivTVars, UnivTypeLocns, !RttiVarMaps),
|
|
|
|
list.map(ToLocn, ExistHeadTypeInfoVars, ExistTypeLocns),
|
|
list.foldl_corresponding(rtti_det_insert_type_info_locn,
|
|
UnconstrainedExistTVars, ExistTypeLocns, !RttiVarMaps),
|
|
|
|
list.map(ToLocn, UnconstrainedInstanceTypeInfoVars,
|
|
UnconstrainedInstanceTypeLocns),
|
|
list.foldl_corresponding(rtti_det_insert_type_info_locn,
|
|
UnconstrainedInstanceTVars,
|
|
UnconstrainedInstanceTypeLocns, !RttiVarMaps),
|
|
|
|
list.foldl(rtti_reuse_typeclass_info_var,
|
|
UnivHeadTypeClassInfoVars, !RttiVarMaps),
|
|
|
|
poly_info_set_rtti_varmaps(!.RttiVarMaps, !Info)
|
|
).
|
|
|
|
% Generate code to produce the values of type_infos and typeclass_infos
|
|
% for existentially quantified type variables in the head.
|
|
%
|
|
% XXX The following code ought to be rewritten to handle
|
|
% existential/universal type_infos and type_class_infos
|
|
% in a more consistent manner.
|
|
%
|
|
:- pred produce_existq_tvars(pred_info::in, proc_arg_vector(prog_var)::in,
|
|
list(tvar)::in, list(prog_var)::in, list(prog_var)::in,
|
|
hlds_goal::in, hlds_goal::out, poly_info::in, poly_info::out) is det.
|
|
|
|
produce_existq_tvars(PredInfo, HeadVars, UnconstrainedTVars,
|
|
TypeInfoHeadVars, ExistTypeClassInfoHeadVars, Goal0, Goal, !Info) :-
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_constraint_map(!.Info, ConstraintMap),
|
|
pred_info_get_arg_types(PredInfo, ArgTypes),
|
|
pred_info_get_tvar_kind_map(PredInfo, KindMap),
|
|
pred_info_get_class_context(PredInfo, PredClassContext),
|
|
|
|
% Generate code to produce values for any existentially quantified
|
|
% typeclass_info variables in the head.
|
|
|
|
PredExistConstraints = PredClassContext ^ exist_constraints,
|
|
get_improved_exists_head_constraints(ConstraintMap, PredExistConstraints,
|
|
ActualExistConstraints),
|
|
ExistQVarsForCall = [],
|
|
Goal0 = hlds_goal(_, GoalInfo),
|
|
Context = goal_info_get_context(GoalInfo),
|
|
make_typeclass_info_vars(ActualExistConstraints, ExistQVarsForCall,
|
|
Context, ExistTypeClassVarsMCAs, ExtraTypeClassGoals, !Info),
|
|
assoc_list.keys(ExistTypeClassVarsMCAs, ExistTypeClassVars),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
list.foldl(rtti_reuse_typeclass_info_var, ExistTypeClassVars,
|
|
RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
|
|
assign_var_list(ExistTypeClassInfoHeadVars,
|
|
ExistTypeClassVars, ExtraTypeClassUnifyGoals),
|
|
|
|
% Figure out the bindings for any unconstrained existentially quantified
|
|
% type variables in the head.
|
|
|
|
( if
|
|
vartypes_is_empty(VarTypes0)
|
|
then
|
|
% This can happen for compiler generated procedures.
|
|
map.init(PredToActualTypeSubst)
|
|
else if
|
|
HeadVarList = proc_arg_vector_to_list(HeadVars),
|
|
lookup_var_types(VarTypes0, HeadVarList, ActualArgTypes),
|
|
type_list_subsumes(ArgTypes, ActualArgTypes, ArgTypeSubst)
|
|
then
|
|
PredToActualTypeSubst = ArgTypeSubst
|
|
else
|
|
% This can happen for unification procedures of equivalence types
|
|
% error("polymorphism.m: type_list_subsumes failed")
|
|
map.init(PredToActualTypeSubst)
|
|
),
|
|
|
|
% Apply the type bindings to the unconstrained type variables to give
|
|
% the actual types, and then generate code to initialize the type_infos
|
|
% for those types.
|
|
|
|
apply_subst_to_tvar_list(KindMap, PredToActualTypeSubst,
|
|
UnconstrainedTVars, ActualTypes),
|
|
polymorphism_do_make_type_info_vars(ActualTypes, Context,
|
|
TypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info),
|
|
assoc_list.keys(TypeInfoVarsMCAs, TypeInfoVars),
|
|
assign_var_list(TypeInfoHeadVars, TypeInfoVars, ExtraTypeInfoUnifyGoals),
|
|
list.condense([[Goal0 | ExtraTypeClassGoals], ExtraTypeClassUnifyGoals,
|
|
ExtraTypeInfoGoals, ExtraTypeInfoUnifyGoals], GoalList),
|
|
conj_list_to_goal(GoalList, GoalInfo, Goal).
|
|
|
|
:- pred assign_var_list(list(prog_var)::in, list(prog_var)::in,
|
|
list(hlds_goal)::out) is det.
|
|
|
|
assign_var_list([], [_ | _], _) :-
|
|
unexpected($pred, "length mismatch").
|
|
assign_var_list([_ | _], [], _) :-
|
|
unexpected($pred, "length mismatch").
|
|
assign_var_list([], [], []).
|
|
assign_var_list([Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) :-
|
|
assign_var(Var1, Var2, Goal),
|
|
assign_var_list(Vars1, Vars2, Goals).
|
|
|
|
:- pred assign_var(prog_var::in, prog_var::in, hlds_goal::out) is det.
|
|
|
|
assign_var(Var1, Var2, Goal) :-
|
|
( if Var1 = Var2 then
|
|
Goal = true_goal
|
|
else
|
|
term.context_init(Context),
|
|
create_pure_atomic_complicated_unification(Var1, rhs_var(Var2),
|
|
Context, umc_explicit, [], Goal)
|
|
).
|
|
|
|
:- pred get_improved_exists_head_constraints(constraint_map::in,
|
|
list(prog_constraint)::in, list(prog_constraint)::out) is det.
|
|
|
|
get_improved_exists_head_constraints(ConstraintMap, ExistConstraints,
|
|
ActualExistConstraints) :-
|
|
list.length(ExistConstraints, NumExistConstraints),
|
|
( if
|
|
search_hlds_constraint_list(ConstraintMap, unproven,
|
|
goal_id_for_head_constraints, NumExistConstraints,
|
|
ActualExistConstraintsPrime)
|
|
then
|
|
ActualExistConstraints = ActualExistConstraintsPrime
|
|
else
|
|
% Some predicates, for example typeclass methods and predicates for
|
|
% which we inferred the type, don't have constraint map entries for
|
|
% the head constraints. In these cases we can just use the external
|
|
% constraints, since there can't be any difference between them and
|
|
% the internal ones.
|
|
ActualExistConstraints = ExistConstraints
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_goal(hlds_goal::in, hlds_goal::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_goal(Goal0, Goal, !Info) :-
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
(
|
|
% We don't need to add type_infos for higher order calls, since the
|
|
% type_infos are added when the closures are constructed, not when
|
|
% they are called.
|
|
GoalExpr0 = generic_call(_, _, _, _, _),
|
|
Goal = Goal0
|
|
;
|
|
GoalExpr0 = plain_call(PredId, _, ArgVars0, _, _, _),
|
|
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
|
|
ExtraVars, ExtraGoals, !Info),
|
|
ArgVars = ExtraVars ++ ArgVars0,
|
|
CallExpr = GoalExpr0 ^ call_args := ArgVars,
|
|
Call = hlds_goal(CallExpr, GoalInfo),
|
|
GoalList = ExtraGoals ++ [Call],
|
|
conj_list_to_goal(GoalList, GoalInfo0, Goal)
|
|
;
|
|
GoalExpr0 = call_foreign_proc(_, PredId, _, _, _, _, _),
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
|
|
( if no_type_info_builtin(PredModule, PredName, PredArity) then
|
|
Goal = Goal0
|
|
else
|
|
polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
|
|
Goal, !Info)
|
|
)
|
|
;
|
|
GoalExpr0 = unify(XVar, Y, Mode, Unification, UnifyContext),
|
|
polymorphism_process_unify(XVar, Y, Mode, Unification, UnifyContext,
|
|
GoalInfo0, Goal, !Info)
|
|
;
|
|
% The rest of the cases just process goals recursively.
|
|
(
|
|
GoalExpr0 = conj(ConjType, Goals0),
|
|
(
|
|
ConjType = plain_conj,
|
|
polymorphism_process_plain_conj(Goals0, Goals, !Info)
|
|
;
|
|
ConjType = parallel_conj,
|
|
get_cache_maps_snapshot("parconj", InitialSnapshot, !Info),
|
|
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot,
|
|
!Info)
|
|
% Unlike with disjunctions, we do not have to reset to
|
|
% InitialSnapshot.
|
|
),
|
|
GoalExpr = conj(ConjType, Goals)
|
|
;
|
|
GoalExpr0 = disj(Goals0),
|
|
get_cache_maps_snapshot("disj", InitialSnapshot, !Info),
|
|
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info),
|
|
set_cache_maps_snapshot("after disj", InitialSnapshot, !Info),
|
|
GoalExpr = disj(Goals)
|
|
;
|
|
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
|
|
get_cache_maps_snapshot("ite", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Cond0, Cond, !Info),
|
|
% If we allowed a type_info created inside Cond to be reused
|
|
% in Then, then we are adding an output variable to Cond.
|
|
% If Cond scope had no outputs to begin with, this would change
|
|
% its determinism.
|
|
set_cache_maps_snapshot("before then", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Then0, Then, !Info),
|
|
set_cache_maps_snapshot("before else", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Else0, Else, !Info),
|
|
set_cache_maps_snapshot("after ite", InitialSnapshot, !Info),
|
|
GoalExpr = if_then_else(Vars, Cond, Then, Else)
|
|
;
|
|
GoalExpr0 = negation(SubGoal0),
|
|
get_cache_maps_snapshot("neg", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
set_cache_maps_snapshot("after neg", InitialSnapshot, !Info),
|
|
GoalExpr = negation(SubGoal)
|
|
;
|
|
GoalExpr0 = switch(Var, CanFail, Cases0),
|
|
get_cache_maps_snapshot("switch", InitialSnapshot, !Info),
|
|
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info),
|
|
set_cache_maps_snapshot("after switch", InitialSnapshot, !Info),
|
|
GoalExpr = switch(Var, CanFail, Cases)
|
|
;
|
|
GoalExpr0 = scope(Reason0, SubGoal0),
|
|
(
|
|
Reason0 = from_ground_term(TermVar, Kind),
|
|
(
|
|
Kind = from_ground_term_initial,
|
|
polymorphism_process_from_ground_term_initial(TermVar,
|
|
GoalInfo0, SubGoal0, GoalExpr, !Info)
|
|
;
|
|
( Kind = from_ground_term_construct
|
|
; Kind = from_ground_term_deconstruct
|
|
; Kind = from_ground_term_other
|
|
),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
GoalExpr = scope(Reason0, SubGoal)
|
|
)
|
|
;
|
|
Reason0 = promise_solutions(_, _),
|
|
% polymorphism_process_goal may cause SubGoal to bind
|
|
% variables (such as PolyConst variables) that SubGoal0 does
|
|
% not bind. If we allowed such variables to be reused outside
|
|
% the scope, that would change the set of variables that the
|
|
% promise would have to cover. We cannot expect and do not want
|
|
% user level programmers making promises about variables added
|
|
% by the compiler.
|
|
get_cache_maps_snapshot("promise_solns", InitialSnapshot,
|
|
!Info),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
set_cache_maps_snapshot("after promise_solns", InitialSnapshot,
|
|
!Info),
|
|
GoalExpr = scope(Reason0, SubGoal)
|
|
;
|
|
( Reason0 = disable_warnings(_, _)
|
|
; Reason0 = promise_purity(_)
|
|
; Reason0 = require_detism(_)
|
|
; Reason0 = require_complete_switch(_)
|
|
; Reason0 = require_switch_arms_detism(_, _)
|
|
; Reason0 = commit(_)
|
|
; Reason0 = barrier(_)
|
|
; Reason0 = loop_control(_, _, _)
|
|
),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
GoalExpr = scope(Reason0, SubGoal)
|
|
;
|
|
Reason0 = exist_quant(_),
|
|
% If we allowed a type_info created inside SubGoal to be reused
|
|
% outside GoalExpr, then we are adding an output variable to
|
|
% the scope. If the scope had no outputs to begin with, this
|
|
% would change the determinism of the scope.
|
|
%
|
|
% However, using a type_info from before the scope in SubGoal
|
|
% is perfectly ok.
|
|
|
|
get_cache_maps_snapshot("exists", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
set_cache_maps_snapshot("after exists", InitialSnapshot,
|
|
!Info),
|
|
GoalExpr = scope(Reason0, SubGoal)
|
|
;
|
|
Reason0 = trace_goal(_, _, _, _, _),
|
|
% Trace goal scopes will be deleted after semantic analysis
|
|
% if their compile-time condition turns out to be false.
|
|
% If we let later code use type_infos introduced inside the
|
|
% scope, the deletion of the scope would leave those variables
|
|
% undefined.
|
|
%
|
|
% We *could* evaluate the compile-time condition here to know
|
|
% whether the deletion will happen or not, but doing so would
|
|
% require breaching the separation between compiler passes.
|
|
|
|
get_cache_maps_snapshot("trace", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
|
|
set_cache_maps_snapshot("after trace", InitialSnapshot, !Info),
|
|
GoalExpr = scope(Reason0, SubGoal)
|
|
)
|
|
),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
;
|
|
GoalExpr0 = shorthand(ShortHand0),
|
|
(
|
|
ShortHand0 = atomic_goal(GoalType, Outer, Inner, Vars,
|
|
MainGoal0, OrElseGoals0, OrElseInners),
|
|
get_cache_maps_snapshot("atomic", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(MainGoal0, MainGoal, !Info),
|
|
polymorphism_process_disj(OrElseGoals0, OrElseGoals,
|
|
InitialSnapshot, !Info),
|
|
set_cache_maps_snapshot("after atomic", InitialSnapshot, !Info),
|
|
ShortHand = atomic_goal(GoalType, Outer, Inner, Vars,
|
|
MainGoal, OrElseGoals, OrElseInners)
|
|
;
|
|
ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
|
|
% We don't let the code inside and outside the try goal share
|
|
% type_info variables for the same reason as with lambda
|
|
% expressions; because those pieces of code will end up
|
|
% in different procedures. However, for try goals, this is true
|
|
% even for the first and second conjuncts.
|
|
get_cache_maps_snapshot("try", InitialSnapshot, !Info),
|
|
( if
|
|
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo),
|
|
SubGoalExpr0 = conj(plain_conj, Conjuncts0),
|
|
Conjuncts0 = [ConjunctA0, ConjunctB0]
|
|
then
|
|
empty_cache_maps(!Info),
|
|
polymorphism_process_goal(ConjunctA0, ConjunctA, !Info),
|
|
empty_cache_maps(!Info),
|
|
polymorphism_process_goal(ConjunctB0, ConjunctB, !Info),
|
|
|
|
Conjuncts = [ConjunctA, ConjunctB],
|
|
SubGoalExpr = conj(plain_conj, Conjuncts),
|
|
SubGoal = hlds_goal(SubGoalExpr, SubGoalInfo)
|
|
else
|
|
unexpected($pred, "malformed try goal")
|
|
),
|
|
set_cache_maps_snapshot("after try", InitialSnapshot, !Info),
|
|
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
|
|
;
|
|
ShortHand0 = bi_implication(_, _),
|
|
unexpected($pred, "bi_implication")
|
|
),
|
|
GoalExpr = shorthand(ShortHand),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo0)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_from_ground_term_initial(prog_var::in,
|
|
hlds_goal_info::in, hlds_goal::in, hlds_goal_expr::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_from_ground_term_initial(TermVar, GoalInfo0, SubGoal0,
|
|
GoalExpr, !Info) :-
|
|
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo0),
|
|
( if SubGoalExpr0 = conj(plain_conj, SubGoals0Prime) then
|
|
SubGoals0 = SubGoals0Prime
|
|
else
|
|
unexpected($pred, "from_ground_term_initial goal is not plain conj")
|
|
),
|
|
polymorphism_process_fgti_goals(SubGoals0,
|
|
[], ConstructOrderMarkedSubGoals,
|
|
fgt_invariants_kept, InvariantsStatus, !Info),
|
|
(
|
|
InvariantsStatus = fgt_invariants_kept,
|
|
Reason = from_ground_term(TermVar, from_ground_term_initial),
|
|
GoalExpr = scope(Reason, SubGoal0)
|
|
;
|
|
InvariantsStatus = fgt_invariants_broken,
|
|
introduce_partial_fgt_scopes(GoalInfo0, SubGoalInfo0,
|
|
ConstructOrderMarkedSubGoals, deconstruct_top_down, SubGoal),
|
|
% Delete the scope wrapper around SubGoal0.
|
|
SubGoal = hlds_goal(GoalExpr, _)
|
|
).
|
|
|
|
:- pred polymorphism_process_fgti_goals(list(hlds_goal)::in,
|
|
list(fgt_marked_goal)::in, list(fgt_marked_goal)::out,
|
|
fgt_invariants_status::in, fgt_invariants_status::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_fgti_goals([], !ConstructOrderMarkedGoals,
|
|
!InvariantsStatus, !Info).
|
|
polymorphism_process_fgti_goals([Goal0 | Goals0], !ConstructOrderMarkedGoals,
|
|
!InvariantsStatus, !Info) :-
|
|
% This is used only if polymorphism_fgt_sanity_tests is enabled.
|
|
OldInfo = !.Info,
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
( if
|
|
GoalExpr0 = unify(XVarPrime, Y, ModePrime, UnificationPrime,
|
|
UnifyContextPrime),
|
|
Y = rhs_functor(ConsIdPrime, _, YVarsPrime)
|
|
then
|
|
XVar = XVarPrime,
|
|
Mode = ModePrime,
|
|
Unification = UnificationPrime,
|
|
UnifyContext = UnifyContextPrime,
|
|
ConsId = ConsIdPrime,
|
|
YVars = YVarsPrime
|
|
else
|
|
unexpected($pred,
|
|
"from_ground_term_initial conjunct is not functor unify")
|
|
),
|
|
polymorphism_process_unify_functor(XVar, ConsId, YVars, Mode,
|
|
Unification, UnifyContext, GoalInfo0, Goal, Changed, !Info),
|
|
(
|
|
Changed = no,
|
|
trace [compiletime(flag("polymorphism_fgt_sanity_tests"))] (
|
|
poly_info_get_varset(OldInfo, VarSetBefore),
|
|
MaxVarBefore = varset.max_var(VarSetBefore),
|
|
poly_info_get_num_reuses(OldInfo, NumReusesBefore),
|
|
|
|
poly_info_get_varset(!.Info, VarSetAfter),
|
|
MaxVarAfter = varset.max_var(VarSetAfter),
|
|
poly_info_get_num_reuses(!.Info, NumReusesAfter),
|
|
|
|
expect(unify(MaxVarBefore, MaxVarAfter), $pred,
|
|
"MaxVarBefore != MaxVarAfter"),
|
|
expect(unify(NumReusesBefore, NumReusesAfter), $pred,
|
|
"NumReusesBefore != NumReusesAfter"),
|
|
expect(unify(Goal0, Goal), $pred,
|
|
"Goal0 != Goal")
|
|
),
|
|
MarkedGoal = fgt_kept_goal(Goal0, XVar, YVars)
|
|
;
|
|
Changed = yes,
|
|
MarkedGoal = fgt_broken_goal(Goal, XVar, YVars),
|
|
!:InvariantsStatus = fgt_invariants_broken
|
|
),
|
|
!:ConstructOrderMarkedGoals = [MarkedGoal | !.ConstructOrderMarkedGoals],
|
|
polymorphism_process_fgti_goals(Goals0, !ConstructOrderMarkedGoals,
|
|
!InvariantsStatus, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_unify(prog_var::in, unify_rhs::in,
|
|
unify_mode::in, unification::in, unify_context::in, hlds_goal_info::in,
|
|
hlds_goal::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_unify(XVar, Y, Mode, Unification0, UnifyContext,
|
|
GoalInfo0, Goal, !Info) :-
|
|
(
|
|
Y = rhs_var(_YVar),
|
|
|
|
% Var-var unifications (simple_test, assign, or complicated_unify)
|
|
% are basically left unchanged. Complicated unifications will
|
|
% eventually get converted into calls, but that is done later on,
|
|
% by simplify.m, not now. At this point we just need to figure out
|
|
% which type_info/typeclass_info variables the unification might need,
|
|
% and insert them in the nonlocals. We have to do that for all var-var
|
|
% unifications, because at this point we haven't done mode analysis so
|
|
% we don't know which ones will become complicated_unifies.
|
|
% Note that we also store the type_info/typeclass_info variables
|
|
% in a field in the unification, which quantification.m uses when
|
|
% requantifying things.
|
|
|
|
poly_info_get_var_types(!.Info, VarTypes),
|
|
lookup_var_type(VarTypes, XVar, Type),
|
|
unification_typeinfos(Type, Unification0, Unification,
|
|
GoalInfo0, GoalInfo, _Changed, !Info),
|
|
Goal = hlds_goal(unify(XVar, Y, Mode, Unification, UnifyContext),
|
|
GoalInfo)
|
|
;
|
|
Y = rhs_functor(ConsId, _, Args),
|
|
polymorphism_process_unify_functor(XVar, ConsId, Args, Mode,
|
|
Unification0, UnifyContext, GoalInfo0, Goal, _Changed, !Info)
|
|
;
|
|
Y = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, Modes, Det, LambdaGoal0),
|
|
|
|
% For lambda expressions, we must recursively traverse the lambda goal.
|
|
% Any type_info variables needed by the lambda goal are created in the
|
|
% lambda goal (not imported from the outside), and any type_info
|
|
% variables created by the lambda goal are not available outside.
|
|
% This is because, after lambda expansion, the code inside and outside
|
|
% the lambda goal will end up in different procedures.
|
|
|
|
get_cache_maps_snapshot("lambda", InitialSnapshot, !Info),
|
|
empty_cache_maps(!Info),
|
|
polymorphism_process_goal(LambdaGoal0, LambdaGoal1, !Info),
|
|
set_cache_maps_snapshot("after lambda", InitialSnapshot, !Info),
|
|
|
|
% Currently we don't allow lambda goals to be existentially typed.
|
|
ExistQVars = [],
|
|
fixup_lambda_quantification(ArgVars0, LambdaVars, ExistQVars,
|
|
LambdaGoal1, LambdaGoal, NonLocalTypeInfos, !Info),
|
|
set_of_var.to_sorted_list(NonLocalTypeInfos, NonLocalTypeInfosList),
|
|
ArgVars = NonLocalTypeInfosList ++ ArgVars0,
|
|
Y1 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars, LambdaVars, Modes, Det, LambdaGoal),
|
|
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
|
|
set_of_var.union(NonLocals0, NonLocalTypeInfos, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
|
|
|
|
% Complicated (in-in) argument unifications are impossible for lambda
|
|
% expressions, so we don't need to worry about adding the type_infos
|
|
% that would be required for such unifications.
|
|
Goal = hlds_goal(unify(XVar, Y1, Mode, Unification0, UnifyContext),
|
|
GoalInfo)
|
|
).
|
|
|
|
:- pred unification_typeinfos(mer_type::in,
|
|
unification::in, unification::out, hlds_goal_info::in, hlds_goal_info::out,
|
|
bool::out, poly_info::in, poly_info::out) is det.
|
|
|
|
unification_typeinfos(Type, !Unification, !GoalInfo, Changed, !Info) :-
|
|
% Compute the type_info/type_class_info variables that would be used
|
|
% if this unification ends up being a complicated_unify.
|
|
type_vars(Type, TypeVars),
|
|
(
|
|
TypeVars = [],
|
|
Changed = no
|
|
;
|
|
TypeVars = [_ | _],
|
|
list.map_foldl(get_type_info_locn, TypeVars, TypeInfoLocns, !Info),
|
|
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo),
|
|
Changed = yes
|
|
).
|
|
|
|
unification_typeinfos_rtti_varmaps(Type, RttiVarMaps, !Unification,
|
|
!GoalInfo) :-
|
|
% This variant is for use by modecheck_unify.m. During mode checking,
|
|
% all the type_infos should appear in the type_info_varmap.
|
|
|
|
% Compute the type_info/type_class_info variables that would be used
|
|
% if this unification ends up being a complicated_unify.
|
|
type_vars(Type, TypeVars),
|
|
list.map(rtti_lookup_type_info_locn(RttiVarMaps), TypeVars,
|
|
TypeInfoLocns),
|
|
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo).
|
|
|
|
:- pred add_unification_typeinfos(list(type_info_locn)::in,
|
|
unification::in, unification::out,
|
|
hlds_goal_info::in, hlds_goal_info::out) is det.
|
|
|
|
add_unification_typeinfos(TypeInfoLocns, !Unification, !GoalInfo) :-
|
|
list.map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0),
|
|
list.remove_dups(TypeInfoVars0, TypeInfoVars),
|
|
|
|
% Insert the TypeInfoVars into the nonlocals field of the goal_info
|
|
% for the unification goal.
|
|
NonLocals0 = goal_info_get_nonlocals(!.GoalInfo),
|
|
set_of_var.insert_list(TypeInfoVars, NonLocals0, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, !GoalInfo),
|
|
|
|
% Also save those type_info vars into a field in the complicated_unify,
|
|
% so that quantification.m can recompute variable scopes properly.
|
|
% This field is also used by modecheck_unify.m -- for complicated
|
|
% unifications, it checks that all these variables are ground.
|
|
(
|
|
!.Unification = complicated_unify(Modes, CanFail, _),
|
|
!:Unification = complicated_unify(Modes, CanFail, TypeInfoVars)
|
|
;
|
|
% This can happen if an earlier stage of compilation has already
|
|
% determined that this unification is particular kind of unification.
|
|
% In that case, the type_info vars won't be needed.
|
|
( !.Unification = construct(_, _, _, _, _, _, _)
|
|
; !.Unification = deconstruct(_, _, _, _, _, _)
|
|
; !.Unification = assign(_, _)
|
|
; !.Unification = simple_test(_, _)
|
|
)
|
|
).
|
|
|
|
:- pred polymorphism_process_unify_functor(prog_var::in, cons_id::in,
|
|
list(prog_var)::in, unify_mode::in, unification::in, unify_context::in,
|
|
hlds_goal_info::in, hlds_goal::out, bool::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_unify_functor(X0, ConsId0, ArgVars0, Mode0, Unification0,
|
|
UnifyContext, GoalInfo0, Goal, Changed, !Info) :-
|
|
poly_info_get_module_info(!.Info, ModuleInfo0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
lookup_var_type(VarTypes0, X0, TypeOfX),
|
|
list.length(ArgVars0, Arity),
|
|
|
|
% We replace any unifications with higher order pred constants
|
|
% by lambda expressions. For example, we replace
|
|
%
|
|
% X = list.append(Y) % Y::in, X::out
|
|
%
|
|
% with
|
|
%
|
|
% X = (
|
|
% pred(A1::in, A2::out) is ... :- list.append(Y, A1, A2)
|
|
% )
|
|
%
|
|
% We do this because it makes two things easier. First, mode analysis
|
|
% needs to check that the lambda goal doesn't bind any nonlocal variables
|
|
% (e.g. `Y' in above example). This would require a bit of moderately
|
|
% tricky special case code if we didn't expand them here. Second, this pass
|
|
% (polymorphism.m) is a lot easier if we don't have to handle higher order
|
|
% constants. If it turns out that the predicate was nonpolymorphic,
|
|
% lambda.m will turn the lambda expression back into a higher order
|
|
% constant again.
|
|
%
|
|
% Note that this transformation is also done by modecheck_unify.m, in case
|
|
% we are rerunning mode analysis after lambda.m has already been run;
|
|
% any changes to the code here will also need to be duplicated there.
|
|
|
|
( if
|
|
% Check if variable has a higher order type.
|
|
ConsId0 = closure_cons(ShroudedPredProcId, _),
|
|
proc(PredId, ProcId0) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
type_is_higher_order_details(TypeOfX, Purity, _PredOrFunc, EvalMethod,
|
|
CalleeArgTypes)
|
|
then
|
|
% An `invalid_proc_id' means the predicate is multi-moded. We can't
|
|
% pick the right mode yet. Perform the rest of the transformation with
|
|
% any mode (the first) but mark the goal with a feature so that mode
|
|
% checking knows to fix it up later.
|
|
( if ProcId0 = invalid_proc_id then
|
|
module_info_pred_info(ModuleInfo0, PredId, PredInfo),
|
|
ProcIds = pred_info_procids(PredInfo),
|
|
(
|
|
ProcIds = [ProcId | _],
|
|
goal_info_add_feature(feature_lambda_undetermined_mode,
|
|
GoalInfo0, GoalInfo1)
|
|
;
|
|
ProcIds = [],
|
|
unexpected($pred, "no modes")
|
|
)
|
|
else
|
|
ProcId = ProcId0,
|
|
GoalInfo1 = GoalInfo0
|
|
),
|
|
% Convert the higher order pred term to a lambda goal.
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
Context = goal_info_get_context(GoalInfo0),
|
|
convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
|
|
ArgVars0, CalleeArgTypes, UnifyContext, GoalInfo1, Context,
|
|
ModuleInfo0, MaybeRHS0, VarSet0, VarSet, VarTypes0, VarTypes),
|
|
poly_info_set_varset_types(VarSet, VarTypes, !Info),
|
|
(
|
|
MaybeRHS0 = ok1(RHS0),
|
|
% Process the unification in its new form.
|
|
polymorphism_process_unify(X0, RHS0, Mode0, Unification0,
|
|
UnifyContext, GoalInfo1, Goal, !Info)
|
|
;
|
|
MaybeRHS0 = error1(Specs),
|
|
poly_info_get_errors(!.Info, Specs0),
|
|
poly_info_set_errors(Specs ++ Specs0, !Info),
|
|
% It doesn't matter what Goal we return, since it won't be used.
|
|
RHS = rhs_functor(int_const(42), is_not_exist_constr, []),
|
|
polymorphism_process_unify(X0, RHS, Mode0, Unification0,
|
|
UnifyContext, GoalInfo1, Goal, !Info)
|
|
),
|
|
Changed = yes
|
|
else if
|
|
% Is this a construction or deconstruction of an existentially
|
|
% typed data type?
|
|
%
|
|
% Check whether the functor had a "new " prefix.
|
|
% If so, assume it is a construction, and strip off the prefix.
|
|
% Otherwise, assume it is a deconstruction.
|
|
|
|
ConsId0 = cons(Functor0, Arity, ConsTypeCtor),
|
|
( if remove_new_prefix(Functor0, OrigFunctor) then
|
|
ConsId = cons(OrigFunctor, Arity, ConsTypeCtor),
|
|
IsExistConstr = is_exist_constr
|
|
else
|
|
ConsId = ConsId0,
|
|
IsExistConstr = is_not_exist_constr
|
|
),
|
|
|
|
% Check whether the functor (with the "new " prefix removed)
|
|
% is an existentially typed functor.
|
|
type_util.get_existq_cons_defn(ModuleInfo0, TypeOfX, ConsId, ConsDefn)
|
|
then
|
|
% Add extra arguments to the unification for the
|
|
% type_info and/or type_class_info variables.
|
|
|
|
lookup_var_types(VarTypes0, ArgVars0, ActualArgTypes),
|
|
polymorphism_process_existq_unify_functor(ConsDefn,
|
|
IsExistConstr, ActualArgTypes, TypeOfX, GoalInfo0,
|
|
ExtraVars, ExtraGoals, !Info),
|
|
ArgVars = ExtraVars ++ ArgVars0,
|
|
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
|
|
set_of_var.insert_list(ExtraVars, NonLocals0, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
|
|
|
|
% Some of the argument unifications may be complicated unifications,
|
|
% which may need type_infos.
|
|
unification_typeinfos(TypeOfX, Unification0, Unification,
|
|
GoalInfo1, GoalInfo, _Changed, !Info),
|
|
|
|
UnifyExpr = unify(X0, rhs_functor(ConsId, IsExistConstr, ArgVars),
|
|
Mode0, Unification, UnifyContext),
|
|
Unify = hlds_goal(UnifyExpr, GoalInfo),
|
|
GoalList = ExtraGoals ++ [Unify],
|
|
conj_list_to_goal(GoalList, GoalInfo0, Goal),
|
|
Changed = yes
|
|
else
|
|
% We leave construction/deconstruction unifications alone.
|
|
% Some of the argument unifications may be complicated unifications,
|
|
% which may need type_infos.
|
|
|
|
% XXX Return original Goal0 if Changed = no.
|
|
unification_typeinfos(TypeOfX, Unification0, Unification,
|
|
GoalInfo0, GoalInfo, Changed, !Info),
|
|
RHS = rhs_functor(ConsId0, is_not_exist_constr, ArgVars0),
|
|
GoalExpr = unify(X0, RHS, Mode0, Unification, UnifyContext),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo)
|
|
).
|
|
|
|
convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
|
|
ArgVars0, PredArgTypes, UnifyContext, GoalInfo0, Context,
|
|
ModuleInfo0, MaybeRHS, !VarSet, !VarTypes) :-
|
|
% Create the new lambda-quantified variables.
|
|
create_fresh_vars(PredArgTypes, LambdaVars, !VarSet, !VarTypes),
|
|
Args = ArgVars0 ++ LambdaVars,
|
|
|
|
% Build up the hlds_goal_expr for the call that will form the lambda goal.
|
|
module_info_pred_proc_info(ModuleInfo0, PredId, ProcId,
|
|
PredInfo, ProcInfo),
|
|
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
QualifiedPName = qualified(PredModule, PredName),
|
|
|
|
% The ConsId's type_ctor shouldn't matter in a call_unify_context.
|
|
ConsId = cons(QualifiedPName, list.length(ArgVars0),
|
|
cons_id_dummy_type_ctor),
|
|
RHS0 = rhs_functor(ConsId, is_not_exist_constr, ArgVars0),
|
|
CallUnifyContext = call_unify_context(X0, RHS0, UnifyContext),
|
|
LambdaGoalExpr = plain_call(PredId, ProcId, Args, not_builtin,
|
|
yes(CallUnifyContext), QualifiedPName),
|
|
|
|
% Construct a goal_info for the lambda goal, making sure to set up
|
|
% the nonlocals field in the goal_info correctly. The goal_id is needed
|
|
% to compute constraint_ids correctly.
|
|
|
|
NonLocals = goal_info_get_nonlocals(GoalInfo0),
|
|
set_of_var.insert_list(LambdaVars, NonLocals, OutsideVars),
|
|
set_of_var.list_to_set(Args, InsideVars),
|
|
set_of_var.intersect(OutsideVars, InsideVars, LambdaNonLocals),
|
|
GoalId = goal_info_get_goal_id(GoalInfo0),
|
|
|
|
instmap_delta_init_unreachable(DummyInstMapDelta),
|
|
DummyDetism = detism_erroneous,
|
|
goal_info_init(LambdaNonLocals, DummyInstMapDelta, DummyDetism, Purity,
|
|
Context, LambdaGoalInfo0),
|
|
goal_info_set_goal_id(GoalId, LambdaGoalInfo0, LambdaGoalInfo),
|
|
LambdaGoal = hlds_goal(LambdaGoalExpr, LambdaGoalInfo),
|
|
|
|
% Work out the modes of the introduced lambda variables and the determinism
|
|
% of the lambda goal.
|
|
lambda_modes_and_det(PredInfo, ProcInfo, Context, LambdaVars,
|
|
MaybeLambdaModesDet),
|
|
|
|
(
|
|
MaybeLambdaModesDet = ok2(LambdaModes, LambdaDet),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
% Higher-order values created in this fashion are always ground.
|
|
Groundness = ho_ground,
|
|
RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal),
|
|
MaybeRHS = ok1(RHS)
|
|
;
|
|
MaybeLambdaModesDet = error2(Specs),
|
|
MaybeRHS = error1(Specs)
|
|
).
|
|
|
|
fix_undetermined_mode_lambda_goal(ModuleInfo, ProcId, RHS0, MaybeRHS) :-
|
|
RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, _LambdaModes0, _LambdaDet0, LambdaGoal0),
|
|
LambdaGoal0 = hlds_goal(_, LambdaGoalInfo),
|
|
goal_to_conj_list(LambdaGoal0, LambdaGoalList0),
|
|
( if
|
|
list.split_last(LambdaGoalList0, LambdaGoalButLast0, LastGoal0),
|
|
LastGoal0 = hlds_goal(LastGoalExpr0, LastGoalInfo0),
|
|
LastGoalExpr0 = plain_call(PredId0, _DummyProcId, Args0, not_builtin,
|
|
MaybeCallUnifyContext0, QualifiedPName0)
|
|
then
|
|
PredId = PredId0,
|
|
% Build up LambdaGoal. It is the same as LambdaGoal0, but with the
|
|
% given ProcId.
|
|
LastGoalExpr = plain_call(PredId0, ProcId, Args0, not_builtin,
|
|
MaybeCallUnifyContext0, QualifiedPName0),
|
|
LastGoal = hlds_goal(LastGoalExpr, LastGoalInfo0),
|
|
conj_list_to_goal(LambdaGoalButLast0 ++ [LastGoal], LambdaGoalInfo,
|
|
LambdaGoal),
|
|
Context = goal_info_get_context(LastGoalInfo0)
|
|
else
|
|
unexpected($pred, "unmatched lambda goal")
|
|
),
|
|
|
|
% Work out the modes of the introduced lambda variables and the determinism
|
|
% of the lambda goal.
|
|
module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
|
|
lambda_modes_and_det(PredInfo, ProcInfo, Context, LambdaVars,
|
|
MaybeLambdaModesDet),
|
|
(
|
|
MaybeLambdaModesDet = ok2(LambdaModes, LambdaDet),
|
|
|
|
% Construct the lambda expression.
|
|
RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal),
|
|
MaybeRHS = ok1(RHS)
|
|
;
|
|
MaybeLambdaModesDet = error2(Specs),
|
|
MaybeRHS = error1(Specs)
|
|
).
|
|
|
|
:- pred lambda_modes_and_det(pred_info::in, proc_info::in, prog_context::in,
|
|
list(prog_var)::in, maybe2(list(mer_mode), determinism)::out) is det.
|
|
|
|
lambda_modes_and_det(PredInfo, ProcInfo, Context, LambdaVars, MaybeResult) :-
|
|
proc_info_get_argmodes(ProcInfo, ArgModes),
|
|
list.length(ArgModes, NumArgModes),
|
|
list.length(LambdaVars, NumLambdaVars),
|
|
list.det_drop(NumArgModes - NumLambdaVars, ArgModes, LambdaModes),
|
|
proc_info_get_declared_determinism(ProcInfo, MaybeDet),
|
|
(
|
|
MaybeDet = yes(Det),
|
|
MaybeResult = ok2(LambdaModes, Det)
|
|
;
|
|
MaybeDet = no,
|
|
pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
|
|
PredOrFuncStr = pred_or_func_to_full_str(PredOrFunc),
|
|
pred_info_get_module_name(PredInfo, PredModuleName),
|
|
pred_info_get_name(PredInfo, PredName),
|
|
PredSymName = qualified(PredModuleName, PredName),
|
|
Pieces = [words("Error: the"), words(PredOrFuncStr),
|
|
qual_sym_name(PredSymName), words("has no declared determinism,"),
|
|
words("so a curried call to it"),
|
|
words("may not be used as a lambda expression."), nl],
|
|
Spec = simplest_spec(severity_error, phase_polymorphism,
|
|
Context, Pieces),
|
|
MaybeResult = error2([Spec])
|
|
).
|
|
|
|
:- pred create_fresh_vars(list(mer_type)::in, list(prog_var)::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
|
|
|
|
create_fresh_vars([], [], !VarSet, !VarTypes).
|
|
create_fresh_vars([Type | Types], [Var | Vars], !VarSet, !VarTypes) :-
|
|
varset.new_var(Var, !VarSet),
|
|
add_var_type(Var, Type, !VarTypes),
|
|
create_fresh_vars(Types, Vars, !VarSet, !VarTypes).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Compute the extra arguments that we need to add to a unification with
|
|
% an existentially quantified data constructor.
|
|
%
|
|
:- pred polymorphism_process_existq_unify_functor(ctor_defn::in,
|
|
is_exist_constr::in, list(mer_type)::in, mer_type::in,
|
|
hlds_goal_info::in, list(prog_var)::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_existq_unify_functor(CtorDefn, IsExistConstr,
|
|
ActualArgTypes, ActualRetType, GoalInfo,
|
|
ExtraVars, ExtraGoals, !Info) :-
|
|
CtorDefn = ctor_defn(CtorTypeVarSet, CtorKindMap,
|
|
CtorMaybeExistConstraints, CtorArgTypes, CtorRetType),
|
|
|
|
% Rename apart the type variables in the constructor definition.
|
|
poly_info_get_typevarset(!.Info, TypeVarSet0),
|
|
tvarset_merge_renaming(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
|
|
CtorToParentRenaming),
|
|
(
|
|
CtorMaybeExistConstraints = exist_constraints(CtorExistConstraints),
|
|
% XXX Could we use _Ctor{Unc,C}onstrainedExistQVars to avoid
|
|
% some of the work below?
|
|
CtorExistConstraints = cons_exist_constraints(CtorExistQVars,
|
|
CtorExistentialConstraints,
|
|
_CtorUnconstrainedExistQVars, _CtorConstrainedExistQVars),
|
|
apply_variable_renaming_to_tvar_list(CtorToParentRenaming,
|
|
CtorExistQVars, ParentExistQVars),
|
|
apply_variable_renaming_to_prog_constraint_list(CtorToParentRenaming,
|
|
CtorExistentialConstraints, ParentExistentialConstraints),
|
|
list.length(ParentExistentialConstraints, NumExistentialConstraints),
|
|
|
|
% Compute the set of _unconstrained_ existentially quantified type
|
|
% variables, and then apply the type bindings to those type variables
|
|
% to figure out what types they are bound to.
|
|
constraint_list_get_tvars(ParentExistentialConstraints,
|
|
ParentExistConstrainedTVars),
|
|
list.delete_elems(ParentExistQVars, ParentExistConstrainedTVars,
|
|
ParentUnconstrainedExistQVars),
|
|
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
|
|
ParentUnconstrainedExistQVars, ActualExistentialTypes)
|
|
;
|
|
CtorMaybeExistConstraints = no_exist_constraints,
|
|
NumExistentialConstraints = 0,
|
|
ActualExistentialTypes = []
|
|
),
|
|
apply_variable_renaming_to_tvar_kind_map(CtorToParentRenaming,
|
|
CtorKindMap, ParentKindMap),
|
|
apply_variable_renaming_to_type_list(CtorToParentRenaming,
|
|
CtorArgTypes, ParentArgTypes),
|
|
apply_variable_renaming_to_type(CtorToParentRenaming, CtorRetType,
|
|
ParentRetType),
|
|
poly_info_set_typevarset(TypeVarSet, !Info),
|
|
|
|
% Compute the type bindings resulting from the functor's actual argument
|
|
% and return types. These are the ones that might bind the ExistQVars.
|
|
type_list_subsumes_det([ParentRetType | ParentArgTypes],
|
|
[ActualRetType | ActualArgTypes], ParentToActualTypeSubst),
|
|
|
|
% Create type_class_info variables for the type class constraints.
|
|
poly_info_get_constraint_map(!.Info, ConstraintMap),
|
|
GoalId = goal_info_get_goal_id(GoalInfo),
|
|
Context = goal_info_get_context(GoalInfo),
|
|
(
|
|
IsExistConstr = is_exist_constr,
|
|
% Assume it is a construction.
|
|
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalId,
|
|
NumExistentialConstraints, ActualExistentialConstraints),
|
|
make_typeclass_info_vars(ActualExistentialConstraints, [], Context,
|
|
ExtraTypeClassVarsMCAs, ExtraTypeClassGoals, !Info),
|
|
assoc_list.keys(ExtraTypeClassVarsMCAs, ExtraTypeClassVars)
|
|
;
|
|
IsExistConstr = is_not_exist_constr,
|
|
% Assume it is a deconstruction.
|
|
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
|
|
NumExistentialConstraints, ActualExistentialConstraints),
|
|
make_existq_typeclass_info_vars(ActualExistentialConstraints, Context,
|
|
ExtraTypeClassVars, ExtraTypeClassGoals, !Info)
|
|
),
|
|
|
|
% Create type_info variables for the _unconstrained_ existentially
|
|
% quantified type variables.
|
|
polymorphism_do_make_type_info_vars(ActualExistentialTypes, Context,
|
|
ExtraTypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info),
|
|
assoc_list.keys(ExtraTypeInfoVarsMCAs, ExtraTypeInfoVars),
|
|
|
|
% The type_class_info variables go AFTER the type_info variables
|
|
% (for consistency with the order for argument passing,
|
|
% and because the RTTI support in the runtime system relies on it)
|
|
|
|
ExtraGoals = ExtraTypeInfoGoals ++ ExtraTypeClassGoals,
|
|
ExtraVars = ExtraTypeInfoVars ++ ExtraTypeClassVars.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_foreign_proc(pred_info::in,
|
|
hlds_goal_expr::in(bound(call_foreign_proc(ground,ground,ground,ground,
|
|
ground,ground,ground))), hlds_goal_info::in, hlds_goal::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
|
|
Goal, !Info) :-
|
|
% Insert the type_info vars into the argname map, so that the foreign_proc
|
|
% can refer to the type_info variable for type T as `TypeInfo_for_T'.
|
|
GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId,
|
|
Args0, ProcExtraArgs, MaybeTraceRuntimeCond, Impl),
|
|
ArgVars0 = list.map(foreign_arg_var, Args0),
|
|
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
|
|
ExtraVars, ExtraGoals, !Info),
|
|
CanOptAwayUnnamed = yes,
|
|
polymorphism_process_foreign_proc_args(PredInfo, CanOptAwayUnnamed, Impl,
|
|
ExtraVars, ExtraArgs),
|
|
Args = ExtraArgs ++ Args0,
|
|
|
|
% Plug it all back together.
|
|
CallExpr = call_foreign_proc(Attributes, PredId, ProcId,
|
|
Args, ProcExtraArgs, MaybeTraceRuntimeCond, Impl),
|
|
Call = hlds_goal(CallExpr, GoalInfo),
|
|
GoalList = ExtraGoals ++ [Call],
|
|
conj_list_to_goal(GoalList, GoalInfo0, Goal).
|
|
|
|
:- pred polymorphism_process_foreign_proc_args(pred_info::in, bool::in,
|
|
pragma_foreign_proc_impl::in, list(prog_var)::in, list(foreign_arg)::out)
|
|
is det.
|
|
|
|
polymorphism_process_foreign_proc_args(PredInfo, CanOptAwayUnnamed, Impl, Vars,
|
|
Args) :-
|
|
pred_info_get_arg_types(PredInfo, PredTypeVarSet, ExistQVars,
|
|
PredArgTypes),
|
|
|
|
% Find out which variables are constrained (so that we don't add
|
|
% type_infos for them).
|
|
pred_info_get_class_context(PredInfo, constraints(UnivCs, ExistCs)),
|
|
UnivVars0 = list.map(get_constrained_vars, UnivCs),
|
|
list.condense(UnivVars0, UnivConstrainedVars),
|
|
ExistVars0 = list.map(get_constrained_vars, ExistCs),
|
|
list.condense(ExistVars0, ExistConstrainedVars),
|
|
|
|
type_vars_list(PredArgTypes, PredTypeVars0),
|
|
list.remove_dups(PredTypeVars0, PredTypeVars1),
|
|
list.delete_elems(PredTypeVars1, UnivConstrainedVars, PredTypeVars2),
|
|
list.delete_elems(PredTypeVars2, ExistConstrainedVars, PredTypeVars),
|
|
|
|
% The argument order is described at the top of this file.
|
|
|
|
in_mode(In),
|
|
out_mode(Out),
|
|
|
|
list.map(foreign_proc_add_typeclass_info(CanOptAwayUnnamed, Out, Impl,
|
|
PredTypeVarSet), ExistCs, ExistTypeClassArgInfos),
|
|
list.map(foreign_proc_add_typeclass_info(CanOptAwayUnnamed, In, Impl,
|
|
PredTypeVarSet), UnivCs, UnivTypeClassArgInfos),
|
|
TypeClassArgInfos = UnivTypeClassArgInfos ++ ExistTypeClassArgInfos,
|
|
|
|
list.filter(
|
|
( pred(X::in) is semidet :-
|
|
list.member(X, ExistQVars)
|
|
), PredTypeVars, ExistUnconstrainedVars, UnivUnconstrainedVars),
|
|
|
|
list.map(foreign_proc_add_typeinfo(CanOptAwayUnnamed, Out, Impl,
|
|
PredTypeVarSet), ExistUnconstrainedVars, ExistTypeArgInfos),
|
|
list.map(foreign_proc_add_typeinfo(CanOptAwayUnnamed, In, Impl,
|
|
PredTypeVarSet), UnivUnconstrainedVars, UnivTypeArgInfos),
|
|
TypeInfoArgInfos = UnivTypeArgInfos ++ ExistTypeArgInfos,
|
|
|
|
ArgInfos = TypeInfoArgInfos ++ TypeClassArgInfos,
|
|
|
|
% Insert type_info/typeclass_info types for all the inserted
|
|
% type_info/typeclass_info vars into the argument type list.
|
|
|
|
TypeInfoTypes = list.map((func(_) = type_info_type), PredTypeVars),
|
|
list.map(build_typeclass_info_type, UnivCs, UnivTypes),
|
|
list.map(build_typeclass_info_type, ExistCs, ExistTypes),
|
|
OrigArgTypes = TypeInfoTypes ++ UnivTypes ++ ExistTypes,
|
|
|
|
make_foreign_args(Vars, ArgInfos, OrigArgTypes, Args).
|
|
|
|
:- pred foreign_proc_add_typeclass_info(bool::in, mer_mode::in,
|
|
pragma_foreign_proc_impl::in, tvarset::in, prog_constraint::in,
|
|
foreign_arg_name_mode_box::out) is det.
|
|
|
|
foreign_proc_add_typeclass_info(CanOptAwayUnnamed, Mode, Impl, TypeVarSet,
|
|
Constraint, MaybeArgNameBox) :-
|
|
Constraint = constraint(SymName, Types),
|
|
Name = sym_name_to_string_sep(SymName, "__"),
|
|
type_vars_list(Types, TypeVars),
|
|
TypeVarNames = list.map(underscore_and_tvar_name(TypeVarSet), TypeVars),
|
|
string.append_list(["TypeClassInfo_for_", Name | TypeVarNames],
|
|
ConstraintVarName),
|
|
% If the variable name corresponding to the typeclass_info isn't mentioned
|
|
% in the C code fragment, don't pass the variable to the C code at all.
|
|
( if
|
|
CanOptAwayUnnamed = yes,
|
|
foreign_proc_does_not_use_variable(Impl, ConstraintVarName)
|
|
then
|
|
MaybeArgName = no
|
|
else
|
|
MaybeArgName = yes(foreign_arg_name_mode(ConstraintVarName, Mode))
|
|
),
|
|
MaybeArgNameBox =
|
|
foreign_arg_name_mode_box(MaybeArgName, bp_native_if_possible).
|
|
|
|
:- pred foreign_proc_add_typeinfo(bool::in, mer_mode::in,
|
|
pragma_foreign_proc_impl::in, tvarset::in, tvar::in,
|
|
foreign_arg_name_mode_box::out) is det.
|
|
|
|
foreign_proc_add_typeinfo(CanOptAwayUnnamed, Mode, Impl, TypeVarSet, TVar,
|
|
MaybeArgNameBox) :-
|
|
( if varset.search_name(TypeVarSet, TVar, TypeVarName) then
|
|
C_VarName = "TypeInfo_for_" ++ TypeVarName,
|
|
% If the variable name corresponding to the type_info isn't mentioned
|
|
% in the C code fragment, don't pass the variable to the C code at all.
|
|
( if
|
|
CanOptAwayUnnamed = yes,
|
|
foreign_proc_does_not_use_variable(Impl, C_VarName)
|
|
then
|
|
MaybeArgName = no
|
|
else
|
|
MaybeArgName = yes(foreign_arg_name_mode(C_VarName, Mode))
|
|
)
|
|
else
|
|
MaybeArgName = no
|
|
),
|
|
MaybeArgNameBox =
|
|
foreign_arg_name_mode_box(MaybeArgName, bp_native_if_possible).
|
|
|
|
:- pred foreign_proc_does_not_use_variable(pragma_foreign_proc_impl::in,
|
|
string::in) is semidet.
|
|
|
|
foreign_proc_does_not_use_variable(Impl, VarName) :-
|
|
% XXX This test used to be turned off with the semidet_fail, as it caused
|
|
% the compiler to abort when compiling declarative_execution.m in stage2,
|
|
% but this is no longer the case.
|
|
not foreign_proc_uses_variable(Impl, VarName).
|
|
|
|
:- func underscore_and_tvar_name(tvarset, tvar) = string.
|
|
|
|
underscore_and_tvar_name(TypeVarSet, TVar) = TVarName :-
|
|
varset.lookup_name(TypeVarSet, TVar, TVarName0),
|
|
TVarName = "_" ++ TVarName0.
|
|
|
|
:- pred polymorphism_process_plain_conj(list(hlds_goal)::in,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_plain_conj([], [], !Info).
|
|
polymorphism_process_plain_conj([Goal0 | Goals0], [Goal | Goals], !Info) :-
|
|
polymorphism_process_goal(Goal0, Goal, !Info),
|
|
polymorphism_process_plain_conj(Goals0, Goals, !Info).
|
|
|
|
:- pred polymorphism_process_par_conj(list(hlds_goal)::in,
|
|
list(hlds_goal)::out, cache_maps::in, poly_info::in, poly_info::out)
|
|
is det.
|
|
|
|
polymorphism_process_par_conj([], [], _, !Info).
|
|
polymorphism_process_par_conj([Goal0 | Goals0], [Goal | Goals],
|
|
InitialSnapshot, !Info) :-
|
|
% Any variable that a later parallel conjunct reuses from an earlier
|
|
% parallel conjunct (a) will definitely require synchronization, whose
|
|
% cost will be greater than the cost of building a typeinfo from scratch,
|
|
% and (b) may drastically reduce the available parallelism, if the earlier
|
|
% conjunct produces the variable late but the later conjunct requires it
|
|
% early.
|
|
set_cache_maps_snapshot("par conjunct", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Goal0, Goal, !Info),
|
|
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot, !Info).
|
|
|
|
:- pred polymorphism_process_disj(list(hlds_goal)::in, list(hlds_goal)::out,
|
|
cache_maps::in, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_disj([], [], _, !Info).
|
|
polymorphism_process_disj([Goal0 | Goals0], [Goal | Goals], InitialSnapshot,
|
|
!Info) :-
|
|
set_cache_maps_snapshot("disjunct", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Goal0, Goal, !Info),
|
|
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info).
|
|
|
|
:- pred polymorphism_process_cases(list(case)::in, list(case)::out,
|
|
cache_maps::in, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_cases([], [], _, !Info).
|
|
polymorphism_process_cases([Case0 | Cases0], [Case | Cases], InitialSnapshot,
|
|
!Info) :-
|
|
Case0 = case(MainConsId, OtherConsIds, Goal0),
|
|
set_cache_maps_snapshot("case", InitialSnapshot, !Info),
|
|
polymorphism_process_goal(Goal0, Goal, !Info),
|
|
Case = case(MainConsId, OtherConsIds, Goal),
|
|
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% XXX document me
|
|
%
|
|
% XXX the following code ought to be rewritten to handle
|
|
% existential/universal type_infos and type_class_infos
|
|
% in a more consistent manner.
|
|
%
|
|
:- pred polymorphism_process_call(pred_id::in, list(prog_var)::in,
|
|
hlds_goal_info::in, hlds_goal_info::out,
|
|
list(prog_var)::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
|
|
ExtraVars, ExtraGoals, !Info) :-
|
|
poly_info_get_var_types(!.Info, VarTypes),
|
|
poly_info_get_typevarset(!.Info, TypeVarSet0),
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
|
|
% The order of the added variables is important, and must match the
|
|
% order specified at the top of this file.
|
|
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
|
|
PredArgTypes),
|
|
pred_info_get_tvar_kind_map(PredInfo, PredKindMap),
|
|
pred_info_get_class_context(PredInfo, PredClassContext),
|
|
|
|
% VarTypes, TypeVarSet* etc come from the caller.
|
|
% PredTypeVarSet, PredArgTypes, PredExistQVars, etc come
|
|
% directly from the callee.
|
|
% ParentArgTypes, ParentExistQVars etc come from a version
|
|
% of the callee that has been renamed apart from the caller.
|
|
%
|
|
% The difference between e.g. PredArgTypes and ParentArgTypes is the
|
|
% application of PredToParentTypeRenaming, which maps the type variables
|
|
% in the callee to new type variables in the caller. Adding the new type
|
|
% variables to TypeVarSet0 yields TypeVarSet.
|
|
|
|
( if varset.is_empty(PredTypeVarSet) then
|
|
% Optimize a common case.
|
|
map.init(PredToParentTypeRenaming),
|
|
TypeVarSet = TypeVarSet0,
|
|
ParentArgTypes = PredArgTypes,
|
|
ParentKindMap = PredKindMap,
|
|
ParentTVars = [],
|
|
ParentExistQVars = []
|
|
else
|
|
% This merge might be a performance bottleneck?
|
|
tvarset_merge_renaming(TypeVarSet0, PredTypeVarSet, TypeVarSet,
|
|
PredToParentTypeRenaming),
|
|
apply_variable_renaming_to_type_list(PredToParentTypeRenaming,
|
|
PredArgTypes, ParentArgTypes),
|
|
type_vars_list(ParentArgTypes, ParentTVars),
|
|
apply_variable_renaming_to_tvar_kind_map(PredToParentTypeRenaming,
|
|
PredKindMap, ParentKindMap),
|
|
apply_variable_renaming_to_tvar_list(PredToParentTypeRenaming,
|
|
PredExistQVars, ParentExistQVars)
|
|
),
|
|
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
( if
|
|
(
|
|
% Optimize for the common case of nonpolymorphic call
|
|
% with no constraints.
|
|
ParentTVars = [],
|
|
PredClassContext = constraints([], [])
|
|
;
|
|
% Some builtins don't need or want the type_info.
|
|
no_type_info_builtin(PredModule, PredName, PredArity)
|
|
)
|
|
then
|
|
GoalInfo = GoalInfo0,
|
|
ExtraGoals = [],
|
|
ExtraVars = []
|
|
else
|
|
poly_info_set_typevarset(TypeVarSet, !Info),
|
|
|
|
% Compute which "parent" type variables are constrained
|
|
% by the type class constraints.
|
|
apply_variable_renaming_to_prog_constraints(PredToParentTypeRenaming,
|
|
PredClassContext, ParentClassContext),
|
|
ParentClassContext = constraints(ParentUnivConstraints,
|
|
ParentExistConstraints),
|
|
constraint_list_get_tvars(ParentUnivConstraints,
|
|
ParentUnivConstrainedTVars),
|
|
constraint_list_get_tvars(ParentExistConstraints,
|
|
ParentExistConstrainedTVars),
|
|
|
|
% Calculate the set of unconstrained type vars. Split these into
|
|
% existential and universal type vars.
|
|
list.remove_dups(ParentTVars, ParentUnconstrainedTVars0),
|
|
list.delete_elems(ParentUnconstrainedTVars0,
|
|
ParentUnivConstrainedTVars, ParentUnconstrainedTVars1),
|
|
list.delete_elems(ParentUnconstrainedTVars1,
|
|
ParentExistConstrainedTVars, ParentUnconstrainedTVars),
|
|
list.delete_elems(ParentUnconstrainedTVars, ParentExistQVars,
|
|
ParentUnconstrainedUnivTVars),
|
|
list.delete_elems(ParentUnconstrainedTVars,
|
|
ParentUnconstrainedUnivTVars, ParentUnconstrainedExistTVars),
|
|
|
|
% Calculate the "parent to actual" binding.
|
|
lookup_var_types(VarTypes, ArgVars0, ActualArgTypes),
|
|
type_list_subsumes_det(ParentArgTypes, ActualArgTypes,
|
|
ParentToActualTypeSubst),
|
|
|
|
% Make the universally quantified typeclass_infos for the call.
|
|
poly_info_get_constraint_map(!.Info, ConstraintMap),
|
|
GoalId = goal_info_get_goal_id(GoalInfo0),
|
|
list.length(ParentUnivConstraints, NumUnivConstraints),
|
|
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalId,
|
|
NumUnivConstraints, ActualUnivConstraints),
|
|
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
|
|
ParentExistQVars, ActualExistQVarTypes),
|
|
( if
|
|
prog_type.type_list_to_var_list(ActualExistQVarTypes,
|
|
ActualExistQVars0)
|
|
then
|
|
ActualExistQVars = ActualExistQVars0
|
|
else
|
|
unexpected($pred, "existq_tvar bound")
|
|
),
|
|
Context = goal_info_get_context(GoalInfo0),
|
|
make_typeclass_info_vars(ActualUnivConstraints, ActualExistQVars,
|
|
Context, ExtraUnivClassVarsMCAs, ExtraUnivClassGoals, !Info),
|
|
assoc_list.keys(ExtraUnivClassVarsMCAs, ExtraUnivClassVars),
|
|
|
|
% Make variables to hold any existentially quantified typeclass_infos
|
|
% in the call, insert them into the typeclass_info map.
|
|
list.length(ParentExistConstraints, NumExistConstraints),
|
|
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
|
|
NumExistConstraints, ActualExistConstraints),
|
|
make_existq_typeclass_info_vars(ActualExistConstraints, Context,
|
|
ExtraExistClassVars, ExtraExistClassGoals, !Info),
|
|
|
|
% Make variables to hold typeinfos for unconstrained universal type
|
|
% vars.
|
|
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
|
|
ParentUnconstrainedUnivTVars, ActualUnconstrainedUnivTypes),
|
|
polymorphism_do_make_type_info_vars(ActualUnconstrainedUnivTypes,
|
|
Context, ExtraUnivTypeInfoVarsMCAs,
|
|
ExtraUnivTypeInfoGoals, !Info),
|
|
assoc_list.keys(ExtraUnivTypeInfoVarsMCAs,
|
|
ExtraUnivTypeInfoVars),
|
|
|
|
% Make variables to hold typeinfos for unconstrained existential type
|
|
% vars.
|
|
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
|
|
ParentUnconstrainedExistTVars, ActualUnconstrainedExistTypes),
|
|
polymorphism_do_make_type_info_vars(ActualUnconstrainedExistTypes,
|
|
Context, ExtraExistTypeInfoVarsMCAs,
|
|
ExtraExistTypeInfoGoals, !Info),
|
|
assoc_list.keys(ExtraExistTypeInfoVarsMCAs,
|
|
ExtraExistTypeInfoVars),
|
|
|
|
% Add up the extra vars and goals.
|
|
ExtraGoals = ExtraUnivClassGoals ++ ExtraExistClassGoals
|
|
++ ExtraUnivTypeInfoGoals ++ ExtraExistTypeInfoGoals,
|
|
ExtraVars = ExtraUnivTypeInfoVars ++ ExtraExistTypeInfoVars
|
|
++ ExtraUnivClassVars ++ ExtraExistClassVars,
|
|
|
|
% Update the nonlocals.
|
|
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
|
|
set_of_var.insert_list(ExtraVars, NonLocals0, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Add the type_info variables for a new call goal. This predicate assumes
|
|
% that process_module has already been run so the called pred has already
|
|
% been processed.
|
|
%
|
|
% XXX This predicate does not yet handle calls whose arguments include
|
|
% existentially quantified types or type class constraints.
|
|
%
|
|
:- pred polymorphism_process_new_call(pred_info::in, proc_info::in,
|
|
pred_id::in, proc_id::in, list(prog_var)::in, builtin_state::in,
|
|
maybe(call_unify_context)::in, sym_name::in, hlds_goal_info::in,
|
|
hlds_goal::out, poly_info::in, poly_info::out) is det.
|
|
:- pragma consider_used(polymorphism_process_new_call/12).
|
|
|
|
polymorphism_process_new_call(CalleePredInfo, CalleeProcInfo, PredId, ProcId,
|
|
CallArgs0, BuiltinState, MaybeCallUnifyContext, SymName,
|
|
GoalInfo0, Goal, !Info) :-
|
|
% document me better
|
|
%
|
|
poly_info_get_typevarset(!.Info, TVarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
lookup_var_types(VarTypes0, CallArgs0, ActualArgTypes0),
|
|
pred_info_get_arg_types(CalleePredInfo, PredTVarSet, _PredExistQVars,
|
|
PredArgTypes),
|
|
proc_info_get_headvars(CalleeProcInfo, CalleeHeadVars),
|
|
proc_info_get_rtti_varmaps(CalleeProcInfo, CalleeRttiVarMaps),
|
|
|
|
% Work out how many type_info args we need to prepend.
|
|
NCallArgs0 = list.length(ActualArgTypes0),
|
|
NPredArgs = list.length(PredArgTypes),
|
|
NExtraArgs = NPredArgs - NCallArgs0,
|
|
( if
|
|
list.drop(NExtraArgs, PredArgTypes, OrigPredArgTypes0),
|
|
list.take(NExtraArgs, CalleeHeadVars, CalleeExtraHeadVars0)
|
|
then
|
|
OrigPredArgTypes = OrigPredArgTypes0,
|
|
CalleeExtraHeadVars = CalleeExtraHeadVars0
|
|
else
|
|
unexpected($pred, "extra args not found")
|
|
),
|
|
|
|
% Work out the bindings of type variables in the call.
|
|
tvarset_merge_renaming(TVarSet0, PredTVarSet, TVarSet,
|
|
PredToParentRenaming),
|
|
apply_variable_renaming_to_type_list(PredToParentRenaming,
|
|
OrigPredArgTypes, OrigParentArgTypes),
|
|
type_list_subsumes_det(OrigParentArgTypes, ActualArgTypes0,
|
|
ParentToActualTSubst),
|
|
poly_info_set_typevarset(TVarSet, !Info),
|
|
|
|
% Look up the type variables that the type_infos in the caller are for,
|
|
% and apply the type bindings to calculate the types that the caller
|
|
% should pass type_infos for.
|
|
GetTypeInfoTypes =
|
|
( pred(ProgVar::in, TypeInfoType::out) is det :-
|
|
rtti_varmaps_var_info(CalleeRttiVarMaps, ProgVar, VarInfo),
|
|
(
|
|
VarInfo = type_info_var(TypeInfoType)
|
|
;
|
|
VarInfo = typeclass_info_var(_),
|
|
unexpected($pred,
|
|
"unsupported: constraints on initialisation preds")
|
|
;
|
|
VarInfo = non_rtti_var,
|
|
unexpected($pred,
|
|
"missing rtti_var_info for initialisation pred")
|
|
)
|
|
),
|
|
list.map(GetTypeInfoTypes, CalleeExtraHeadVars, PredTypeInfoTypes),
|
|
apply_variable_renaming_to_type_list(PredToParentRenaming,
|
|
PredTypeInfoTypes, ParentTypeInfoTypes),
|
|
apply_rec_subst_to_type_list(ParentToActualTSubst, ParentTypeInfoTypes,
|
|
ActualTypeInfoTypes),
|
|
|
|
% Construct goals to make the required type_infos.
|
|
Ctxt = term.context_init,
|
|
polymorphism_do_make_type_info_vars(ActualTypeInfoTypes, Ctxt,
|
|
ExtraArgsConstArgs, ExtraGoals, !Info),
|
|
assoc_list.keys(ExtraArgsConstArgs, ExtraArgs),
|
|
CallArgs = ExtraArgs ++ CallArgs0,
|
|
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
|
|
NonLocals1 = set_of_var.list_to_set(ExtraArgs),
|
|
set_of_var.union(NonLocals0, NonLocals1, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
|
|
CallGoalExpr = plain_call(PredId, ProcId, CallArgs, BuiltinState,
|
|
MaybeCallUnifyContext, SymName),
|
|
CallGoal = hlds_goal(CallGoalExpr, GoalInfo),
|
|
conj_list_to_goal(ExtraGoals ++ [CallGoal], GoalInfo, Goal).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% If the pred we are processing is a polymorphic predicate, or contains
|
|
% polymorphically-typed goals, we may need to fix up the quantification
|
|
% (nonlocal variables) of the goal so that it includes the extra type_info
|
|
% variables and typeclass_info variables that we added to the headvars
|
|
% or the arguments of existentially typed predicate calls, function calls
|
|
% and deconstruction unifications.
|
|
%
|
|
% Type(class)-infos added for ground types passed to predicate calls,
|
|
% function calls and existentially typed construction unifications
|
|
% do not require requantification because they are local to the conjunction
|
|
% containing the type(class)-info construction and the goal which uses the
|
|
% type(class)-info. The nonlocals for those goals are adjusted by
|
|
% the code which creates/alters them. However, reusing a type_info changes
|
|
% it from being local to nonlocal.
|
|
%
|
|
:- pred fixup_quantification(proc_arg_vector(prog_var)::in,
|
|
existq_tvars::in, hlds_goal::in, hlds_goal::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
fixup_quantification(HeadVars, ExistQVars, Goal0, Goal, !Info) :-
|
|
( if
|
|
% Optimize a common case.
|
|
ExistQVars = [],
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_varmaps_no_tvars(RttiVarMaps0),
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
NumReuses = 0
|
|
then
|
|
Goal = Goal0
|
|
else
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
OutsideVars = proc_arg_vector_to_set(HeadVars),
|
|
implicitly_quantify_goal_general(ordinary_nonlocals_maybe_lambda,
|
|
set_to_bitset(OutsideVars), _Warnings, Goal0, Goal,
|
|
VarSet0, VarSet, VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info)
|
|
).
|
|
|
|
% If the lambda goal we are processing is polymorphically typed, we may
|
|
% need to fix up the quantification (nonlocal variables) so that it
|
|
% includes the type_info variables and typeclass_info variables for
|
|
% any polymorphically typed variables in the nonlocals set or in the
|
|
% arguments (either the lambda vars or the implicit curried argument
|
|
% variables). Including typeinfos for arguments which are not in the
|
|
% nonlocals set of the goal, i.e. unused arguments, is necessary only
|
|
% if typeinfo_liveness is set, but we do it always, since we don't have
|
|
% the options available here, and the since cost is pretty minimal.
|
|
%
|
|
:- pred fixup_lambda_quantification(list(prog_var)::in,
|
|
list(prog_var)::in, existq_tvars::in, hlds_goal::in, hlds_goal::out,
|
|
set_of_progvar::out, poly_info::in, poly_info::out) is det.
|
|
|
|
fixup_lambda_quantification(ArgVars, LambdaVars, ExistQVars, !Goal,
|
|
NewOutsideVars, !Info) :-
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
( if rtti_varmaps_no_tvars(RttiVarMaps0) then
|
|
set_of_var.init(NewOutsideVars)
|
|
else
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
!.Goal = hlds_goal(_, GoalInfo0),
|
|
NonLocals = goal_info_get_nonlocals(GoalInfo0),
|
|
set_of_var.insert_list(ArgVars, NonLocals, NonLocalsPlusArgs0),
|
|
set_of_var.insert_list(LambdaVars,
|
|
NonLocalsPlusArgs0, NonLocalsPlusArgs),
|
|
goal_util.extra_nonlocal_typeinfos(RttiVarMaps0, VarTypes0,
|
|
ExistQVars, NonLocalsPlusArgs, NewOutsideVars),
|
|
set_of_var.union(NonLocals, NewOutsideVars, OutsideVars),
|
|
implicitly_quantify_goal_general(ordinary_nonlocals_maybe_lambda,
|
|
OutsideVars, _Warnings, !Goal,
|
|
VarSet0, VarSet, VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Given the list of constraints for a called predicate, create a list of
|
|
% variables to hold the typeclass_info for those constraints, and create
|
|
% a list of goals to initialize those typeclass_info variables to the
|
|
% appropriate typeclass_info structures for the constraints.
|
|
%
|
|
% Constraints should be renamed-apart and actual-to-formal substituted
|
|
% constraints. Constraints which are already in the rtti_varmaps are
|
|
% assumed to have already had their typeclass_infos initialized; for them,
|
|
% we just return the variable in the rtti_varmaps.
|
|
%
|
|
:- pred make_typeclass_info_vars(list(prog_constraint)::in,
|
|
existq_tvars::in, prog_context::in,
|
|
assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_vars(Constraints, ExistQVars, Context,
|
|
TypeClassInfoVarsMCAs, ExtraGoals, !Info) :-
|
|
SeenInstances = [],
|
|
make_typeclass_info_vars_2(Constraints, SeenInstances, ExistQVars, Context,
|
|
TypeClassInfoVarsMCAs, ExtraGoals, !Info).
|
|
|
|
% Accumulator version of the above.
|
|
%
|
|
:- pred make_typeclass_info_vars_2(list(prog_constraint)::in,
|
|
list(prog_constraint)::in, existq_tvars::in, prog_context::in,
|
|
assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_vars_2([], _Seen, _ExistQVars, _Context,
|
|
[], [], !Info).
|
|
make_typeclass_info_vars_2([Constraint | Constraints], Seen, ExistQVars,
|
|
Context, [TypeClassInfoVarMCA | TypeClassInfoVarsMCAs],
|
|
ExtraGoals, !Info) :-
|
|
make_typeclass_info_var(Constraint, [Constraint | Seen],
|
|
ExistQVars, Context, TypeClassInfoVarMCA, HeadExtraGoals, !Info),
|
|
make_typeclass_info_vars_2(Constraints, Seen, ExistQVars,
|
|
Context, TypeClassInfoVarsMCAs, TailExtraGoals, !Info),
|
|
ExtraGoals = HeadExtraGoals ++ TailExtraGoals.
|
|
|
|
:- pred make_typeclass_info_var(prog_constraint::in,
|
|
list(prog_constraint)::in, existq_tvars::in, prog_context::in,
|
|
pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_var(Constraint, Seen, ExistQVars, Context,
|
|
TypeClassInfoVarMCA, Goals, !Info) :-
|
|
( if
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
|
|
OldTypeClassInfoVar)
|
|
then
|
|
% We already have a typeclass_info for this constraint, either from
|
|
% a parameter to the pred or from an existentially quantified goal
|
|
% that we have already processed.
|
|
TypeClassInfoVar = OldTypeClassInfoVar,
|
|
TypeClassInfoVarMCA = TypeClassInfoVar - no,
|
|
Goals = []
|
|
else if
|
|
% We don't have the typeclass_info, so we must either have a proof
|
|
% that tells us how to make it, or ...
|
|
poly_info_get_proof_map(!.Info, ProofMap),
|
|
map.search(ProofMap, Constraint, Proof)
|
|
then
|
|
make_typeclass_info_from_proof(Constraint, Seen, Proof, ExistQVars,
|
|
Context, TypeClassInfoVarMCA, Goals, !Info)
|
|
else
|
|
% ... it will be produced by an existentially typed goal that
|
|
% we will process later on.
|
|
make_typeclass_info_head_var(do_record_type_info_locns, Constraint,
|
|
TypeClassInfoVar, !Info),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_reuse_typeclass_info_var(TypeClassInfoVar,
|
|
RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
|
|
TypeClassInfoVarMCA = TypeClassInfoVar - no,
|
|
Goals = []
|
|
).
|
|
|
|
:- pred make_typeclass_info_from_proof(prog_constraint::in,
|
|
list(prog_constraint)::in, constraint_proof::in, existq_tvars::in,
|
|
prog_context::in, pair(prog_var, maybe(const_struct_arg))::out,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_from_proof(Constraint, Seen, Proof,
|
|
ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info) :-
|
|
(
|
|
% XXX MR_Dictionary should have MR_Dictionaries for superclass
|
|
% We have to extract the typeclass_info from another one.
|
|
Proof = superclass(SubClassConstraint),
|
|
make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
|
|
ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info)
|
|
;
|
|
% We have to construct the typeclass_info using an instance
|
|
% declaration.
|
|
Proof = apply_instance(InstanceNum),
|
|
make_typeclass_info_from_instance(Constraint, Seen, InstanceNum,
|
|
ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info)
|
|
).
|
|
|
|
:- pred make_typeclass_info_from_subclass(prog_constraint::in,
|
|
list(prog_constraint)::in, prog_constraint::in, existq_tvars::in,
|
|
prog_context::in, pair(prog_var, maybe(const_struct_arg))::out,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
|
|
ExistQVars, Context, TypeClassInfoVar - MaybeTCIConstArg, Goals,
|
|
!Info) :-
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
impure set_level(Level + 1),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("make_typeclass_info_from_subclass", !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("Constraint: ", !IO),
|
|
io.write(Constraint, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("Seen: ", !IO),
|
|
( if Seen = [Constraint] then
|
|
io.write_string("[Constraint]\n", !IO)
|
|
else
|
|
io.write(Seen, !IO),
|
|
io.nl(!IO)
|
|
),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("SubClassConstraint: ", !IO),
|
|
io.write(SubClassConstraint, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("ExistQVars: ", !IO),
|
|
io.write(ExistQVars, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
|
|
% Work out where to extract the typeclass info from.
|
|
SubClassConstraint = constraint(SubClassName, SubClassTypes),
|
|
list.length(SubClassTypes, SubClassArity),
|
|
SubClassId = class_id(SubClassName, SubClassArity),
|
|
|
|
% Make the typeclass_info for the subclass.
|
|
make_typeclass_info_var(SubClassConstraint, Seen, ExistQVars, Context,
|
|
SubClassVarMCA, SubClassVarGoals, !Info),
|
|
SubClassVarMCA = SubClassVar - SubClassMCA,
|
|
|
|
% Look up the definition of the subclass.
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
map.lookup(ClassTable, SubClassId, SubClassDefn),
|
|
|
|
% Work out which superclass typeclass_info to take.
|
|
map.from_corresponding_lists(SubClassDefn ^ classdefn_vars, SubClassTypes,
|
|
SubTypeSubst),
|
|
apply_subst_to_prog_constraint_list(SubTypeSubst,
|
|
SubClassDefn ^ classdefn_supers, SuperClasses),
|
|
( if
|
|
list.index1_of_first_occurrence(SuperClasses, Constraint,
|
|
SuperClassIndexPrime)
|
|
then
|
|
SuperClassIndex = SuperClassIndexPrime
|
|
else
|
|
% We shouldn't have got this far if the constraints were not satisfied.
|
|
unexpected($pred, "constraint not in constraint list")
|
|
),
|
|
|
|
(
|
|
SubClassMCA = yes(SubClassConstArg),
|
|
(
|
|
SubClassConstArg = csa_constant(_, _),
|
|
unexpected($pred, "typeclass infos need a cell")
|
|
;
|
|
SubClassConstArg = csa_const_struct(SubClassConstNum),
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb),
|
|
lookup_const_struct_num(ConstStructDb, SubClassConstNum,
|
|
SubClassConstStruct),
|
|
SubClassConstStruct = const_struct(SubClassConsId, SubClassArgs,
|
|
_, _),
|
|
( if
|
|
SubClassConsId = typeclass_info_cell_constructor,
|
|
SubClassArgs = [BTCIArg | OtherArgs],
|
|
BTCIArg = csa_constant(BTCIConsId, _),
|
|
BTCIConsId = base_typeclass_info_const(_, SubClassId,
|
|
SubInstanceNum, _),
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
map.lookup(InstanceTable, SubClassId, SubInstanceDefns),
|
|
list.index1(SubInstanceDefns, SubInstanceNum, SubInstanceDefn),
|
|
num_extra_instance_args(SubInstanceDefn, NumExtra),
|
|
Index = NumExtra + SuperClassIndex,
|
|
list.det_index1(OtherArgs, Index, SelectedArg),
|
|
SelectedArg = csa_const_struct(SelectedConstNum)
|
|
then
|
|
materialize_typeclass_info_var(Constraint, SelectedConstNum,
|
|
TypeClassInfoVar, Goals, !Info),
|
|
MaybeTCIConstArg = yes(SelectedArg)
|
|
else
|
|
unexpected($pred, "unexpected typeclass info structure")
|
|
)
|
|
),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr, ResultStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
impure set_level(Level - 1),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', (Level-1) * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("subclass constant result ", !IO),
|
|
io.write(TypeClassInfoVar - MaybeTCIConstArg, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
;
|
|
SubClassMCA = no,
|
|
new_typeclass_info_var(Constraint, typeclass_info_kind,
|
|
TypeClassInfoVar, _TypeClassInfoVarType, !Info),
|
|
get_poly_const(SuperClassIndex, IndexVar, IndexGoals, !Info),
|
|
|
|
% We extract the superclass typeclass_info by inserting a call
|
|
% to superclass_from_typeclass_info in private_builtin.
|
|
goal_util.generate_simple_call(ModuleInfo,
|
|
mercury_private_builtin_module, "superclass_from_typeclass_info",
|
|
pf_predicate, only_mode, detism_det, purity_pure,
|
|
[SubClassVar, IndexVar, TypeClassInfoVar], [],
|
|
instmap_delta_bind_no_var, term.context_init, SuperClassGoal),
|
|
Goals = SubClassVarGoals ++ IndexGoals ++ [SuperClassGoal],
|
|
MaybeTCIConstArg = no,
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr, ResultStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
impure set_level(Level - 1),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', (Level-1) * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("subclass computed result ", !IO),
|
|
io.write(TypeClassInfoVar - MaybeTCIConstArg, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
:- pred make_typeclass_info_from_instance(prog_constraint::in,
|
|
list(prog_constraint)::in, int::in, existq_tvars::in, prog_context::in,
|
|
pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_from_instance(Constraint, Seen, InstanceNum, ExistQVars,
|
|
Context, TypeClassInfoVarMCA, Goals, !Info) :-
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
impure set_level(Level + 1),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("make_typeclass_info_from_instance", !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("Constraint: ", !IO),
|
|
io.write(Constraint, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("Seen: ", !IO),
|
|
( if Seen = [Constraint] then
|
|
io.write_string("[Constraint]\n", !IO)
|
|
else
|
|
io.write(Seen, !IO),
|
|
io.nl(!IO)
|
|
),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("InstanceNum: ", !IO),
|
|
io.write(InstanceNum, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("ExistQVars: ", !IO),
|
|
io.write(ExistQVars, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb0),
|
|
InstanceId = ciid(InstanceNum, Constraint, Seen),
|
|
( if
|
|
search_for_constant_instance(ConstStructDb0, InstanceId,
|
|
InstanceIdConstNum)
|
|
then
|
|
materialize_typeclass_info_var(Constraint, InstanceIdConstNum,
|
|
TypeClassInfoVar, Goals, !Info),
|
|
TypeClassInfoVarMCA =
|
|
TypeClassInfoVar - yes(csa_const_struct(InstanceIdConstNum)),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr, ResultStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
impure set_level(Level - 1),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', (Level-1) * 4),
|
|
(
|
|
Goals = [],
|
|
ResultStr = "instance doubly cached result "
|
|
;
|
|
Goals = [_ | _],
|
|
ResultStr = "instance cached result "
|
|
),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string(ResultStr, !IO),
|
|
io.write(TypeClassInfoVarMCA, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
else
|
|
do_make_typeclass_info_from_instance(InstanceId, ExistQVars,
|
|
Context, TypeClassInfoVarMCA, Goals, !Info),
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
impure set_level(Level - 1),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', (Level-1) * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("instance computed result: ", !IO),
|
|
io.write(TypeClassInfoVarMCA, !IO),
|
|
io.nl(!IO),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("type_info_var_map ", !IO),
|
|
poly_info_get_type_info_var_map(!.Info,
|
|
TypeInfoVarMap),
|
|
io.write(TypeInfoVarMap, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("typeclass_info_map ", !IO),
|
|
poly_info_get_typeclass_info_map(!.Info,
|
|
TypeClassInfoMap),
|
|
io.write(TypeClassInfoMap, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("struct_var_map ", !IO),
|
|
poly_info_get_const_struct_var_map(!.Info,
|
|
ConstStructVarMap),
|
|
io.write(ConstStructVarMap, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
:- pred do_make_typeclass_info_from_instance(const_instance_id::in,
|
|
existq_tvars::in, prog_context::in,
|
|
pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
do_make_typeclass_info_from_instance(InstanceId, ExistQVars, Context,
|
|
TypeClassInfoVarMCA, Goals, !Info) :-
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_instance_table(ModuleInfo, InstanceTable),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
poly_info_get_typevarset(!.Info, TypeVarSet),
|
|
poly_info_get_proof_map(!.Info, ProofMap0),
|
|
|
|
InstanceId = ciid(InstanceNum, Constraint, Seen),
|
|
Constraint = constraint(ClassName, ConstrainedTypes),
|
|
|
|
list.length(ConstrainedTypes, ClassArity),
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
|
|
map.lookup(InstanceTable, ClassId, InstanceList),
|
|
list.det_index1(InstanceList, InstanceNum, ProofInstanceDefn),
|
|
|
|
ProofInstanceDefn = hlds_instance_defn(_, InstanceTypes, _, _, _,
|
|
InstanceConstraints, _, _, InstanceTVarset, InstanceProofMap),
|
|
|
|
% XXX kind inference:
|
|
% we assume all tvars have kind `star'.
|
|
map.init(KindMap),
|
|
|
|
type_vars_list(InstanceTypes, InstanceTvars),
|
|
get_unconstrained_tvars(InstanceTvars, InstanceConstraints,
|
|
UnconstrainedTvars),
|
|
|
|
% We can ignore the new typevarset because all the type variables
|
|
% in the instance constraints and superclass proofs must appear
|
|
% in the arguments of the instance, and all such variables
|
|
% are bound when we call type_list_subsumes then apply
|
|
% the resulting bindings.
|
|
tvarset_merge_renaming(TypeVarSet, InstanceTVarset, _NewTVarset, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, InstanceTypes,
|
|
RenamedInstanceTypes),
|
|
type_list_subsumes_det(RenamedInstanceTypes, ConstrainedTypes,
|
|
InstanceSubst),
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming,
|
|
InstanceConstraints, RenamedInstanceConstraints),
|
|
apply_rec_subst_to_prog_constraint_list(InstanceSubst,
|
|
RenamedInstanceConstraints, ActualInstanceConstraints0),
|
|
% XXX document diamond as guess
|
|
% XXX does anyone know what the preceding line means?
|
|
list.delete_elems(ActualInstanceConstraints0, Seen,
|
|
ActualInstanceConstraints),
|
|
apply_variable_renaming_to_constraint_proof_map(Renaming,
|
|
InstanceProofMap, RenamedInstanceProofMap),
|
|
apply_rec_subst_to_constraint_proof_map(InstanceSubst,
|
|
RenamedInstanceProofMap, ActualInstanceProofMap),
|
|
|
|
apply_variable_renaming_to_tvar_list(Renaming, UnconstrainedTvars,
|
|
RenamedUnconstrainedTvars),
|
|
apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap,
|
|
RenamedKindMap),
|
|
apply_rec_subst_to_tvar_list(RenamedKindMap, InstanceSubst,
|
|
RenamedUnconstrainedTvars, ActualUnconstrainedTypes),
|
|
|
|
map.overlay(ProofMap0, ActualInstanceProofMap, ProofMap),
|
|
|
|
get_var_maps_snapshot("make_typeclass_info_from_instance",
|
|
InitialVarMapsSnapshot, !Info),
|
|
|
|
% Make the type_infos for the types that are constrained by this.
|
|
% These are packaged in the typeclass_info.
|
|
polymorphism_do_make_type_info_vars(ConstrainedTypes, Context,
|
|
ArgTypeInfoVarsMCAs, TypeInfoGoals, !Info),
|
|
|
|
% Make the typeclass_infos for the constraints from the context of the
|
|
% instance decl.
|
|
make_typeclass_info_vars_2(ActualInstanceConstraints, Seen, ExistQVars,
|
|
Context, ArgTypeClassInfoVarsMCAs, InstanceConstraintGoals, !Info),
|
|
|
|
% Make the type_infos for the unconstrained type variables
|
|
% from the head of the instance declaration.
|
|
polymorphism_do_make_type_info_vars(ActualUnconstrainedTypes, Context,
|
|
ArgUnconstrainedTypeInfoVarsMCAs, UnconstrainedTypeInfoGoals, !Info),
|
|
|
|
% --------------------- %
|
|
|
|
map.lookup(ClassTable, ClassId, ClassDefn),
|
|
|
|
get_arg_superclass_vars(ClassDefn, ConstrainedTypes, ProofMap,
|
|
ExistQVars, ArgSuperClassVarsMCAs, SuperClassGoals, !Info),
|
|
|
|
PrevGoals = UnconstrainedTypeInfoGoals ++ TypeInfoGoals ++
|
|
InstanceConstraintGoals ++ SuperClassGoals,
|
|
% Lay out the argument variables as expected in the typeclass_info.
|
|
ArgVarsMCAs = ArgUnconstrainedTypeInfoVarsMCAs ++
|
|
ArgTypeClassInfoVarsMCAs ++
|
|
ArgSuperClassVarsMCAs ++ ArgTypeInfoVarsMCAs,
|
|
list.map(make_const_or_var_arg, ArgVarsMCAs, ArgCOVAs),
|
|
|
|
Constraint = constraint(ConstraintClassName, ConstraintArgTypes),
|
|
poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0),
|
|
( if
|
|
map.search(TypeClassInfoMap0, ConstraintClassName, ClassNameMap0),
|
|
map.search(ClassNameMap0, ConstraintArgTypes, OldEntry0),
|
|
OldEntry0 = typeclass_info_map_entry(_BaseConsId, ArgsMap0),
|
|
map.search(ArgsMap0, ArgCOVAs, OldTypeClassInfoVarMCA0)
|
|
then
|
|
TypeClassInfoVarMCA = OldTypeClassInfoVarMCA0,
|
|
Goals = [],
|
|
set_var_maps_snapshot("make_typeclass_info",
|
|
InitialVarMapsSnapshot, !Info),
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 2, !Info)
|
|
else
|
|
BaseConsId = base_typeclass_info_cons_id(InstanceTable,
|
|
Constraint, InstanceNum, InstanceTypes),
|
|
materialize_base_typeclass_info_var(Constraint, BaseConsId, BaseVar,
|
|
BaseGoals, !Info),
|
|
construct_typeclass_info(Constraint, BaseVar, BaseConsId, ArgVarsMCAs,
|
|
InitialVarMapsSnapshot, TypeClassInfoVar, TypeClassInfoMCA,
|
|
BaseGoals ++ PrevGoals, Goals, !Info),
|
|
TypeClassInfoVarMCA = TypeClassInfoVar - TypeClassInfoMCA,
|
|
|
|
% We must start the search from scratch, since construct_typeclass_info
|
|
% may have reset all the cache maps.
|
|
poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap1),
|
|
( if
|
|
map.search(TypeClassInfoMap1, ConstraintClassName, ClassNameMap1)
|
|
then
|
|
( if map.search(ClassNameMap1, ConstraintArgTypes, OldEntry1) then
|
|
OldEntry1 = typeclass_info_map_entry(BaseConsId1, ArgsMap1),
|
|
expect(unify(BaseConsId1, BaseConsId), $pred,
|
|
"BaseConsId1 != BaseConsId"),
|
|
map.det_insert(ArgCOVAs, TypeClassInfoVarMCA,
|
|
ArgsMap1, ArgsMap),
|
|
Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
|
|
map.det_update(ConstraintArgTypes, Entry,
|
|
ClassNameMap1, ClassNameMap),
|
|
map.det_update(ConstraintClassName, ClassNameMap,
|
|
TypeClassInfoMap1, TypeClassInfoMap)
|
|
else
|
|
ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA),
|
|
Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
|
|
map.det_insert(ConstraintArgTypes, Entry,
|
|
ClassNameMap1, ClassNameMap),
|
|
map.det_update(ConstraintClassName, ClassNameMap,
|
|
TypeClassInfoMap1, TypeClassInfoMap)
|
|
)
|
|
else
|
|
ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA),
|
|
Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
|
|
ClassNameMap = map.singleton(ConstraintArgTypes, Entry),
|
|
map.det_insert(ConstraintClassName, ClassNameMap,
|
|
TypeClassInfoMap1, TypeClassInfoMap)
|
|
),
|
|
poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info)
|
|
),
|
|
|
|
( if
|
|
TypeClassInfoVarMCA = _ - yes(TypeClassInfoConstArg),
|
|
TypeClassInfoConstArg = csa_const_struct(TypeClassInfoConstArgNum)
|
|
then
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb1),
|
|
insert_constant_instance(InstanceId, TypeClassInfoConstArgNum,
|
|
ConstStructDb1, ConstStructDb),
|
|
poly_info_set_const_struct_db(ConstStructDb, !Info)
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred construct_typeclass_info(prog_constraint::in,
|
|
prog_var::in, cons_id::in,
|
|
assoc_list(prog_var, maybe(const_struct_arg))::in, var_maps::in,
|
|
prog_var::out, maybe(const_struct_arg)::out,
|
|
list(hlds_goal)::in, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
construct_typeclass_info(Constraint, BaseVar, BaseConsId, ArgVarsMCAs,
|
|
InitialVarMapsSnapshot, TypeClassInfoVar, TypeClassInfoMCA,
|
|
PrevGoals, AllGoals, !Info) :-
|
|
% Build a unification to add the argvars to the base_typeclass_info.
|
|
ConsId = typeclass_info_cell_constructor,
|
|
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb0),
|
|
const_struct_db_get_poly_enabled(ConstStructDb0, ConstStructEnabled),
|
|
( if
|
|
ConstStructEnabled = yes,
|
|
all_are_const_struct_args(ArgVarsMCAs, VarConstArgs)
|
|
then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
|
|
set_var_maps_snapshot("construct_typeclass_info",
|
|
InitialVarMapsSnapshot, !Info),
|
|
new_typeclass_info_var(Constraint, typeclass_info_kind,
|
|
TypeClassInfoVar, TypeClassInfoVarType, !Info),
|
|
|
|
build_typeclass_info_type(Constraint, BaseConstArgType),
|
|
BaseConstArg = csa_constant(BaseConsId, BaseConstArgType),
|
|
StructArgs = [BaseConstArg | VarConstArgs],
|
|
list.map(get_inst_of_const_struct_arg(ConstStructDb0),
|
|
VarConstArgs, VarInsts),
|
|
list.length(ArgVarsMCAs, NumArgs),
|
|
InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgs),
|
|
StructInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(InstConsId, VarInsts)]),
|
|
ConstStruct = const_struct(ConsId, StructArgs,
|
|
TypeClassInfoVarType, StructInst),
|
|
lookup_insert_const_struct(ConstStruct, ConstNum,
|
|
ConstStructDb0, ConstStructDb),
|
|
poly_info_set_const_struct_db(ConstStructDb, !Info),
|
|
TypeClassInfoConstArg = csa_const_struct(ConstNum),
|
|
TypeClassInfoMCA = yes(TypeClassInfoConstArg),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
ConstConsId = typeclass_info_const(ConstNum),
|
|
Unification = construct(TypeClassInfoVar, ConstConsId, [], [],
|
|
construct_statically, cell_is_shared, no_construct_sub_info),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
TypeClassInfoRHS = rhs_functor(ConstConsId, is_not_exist_constr, []),
|
|
GoalExpr = unify(TypeClassInfoVar, TypeClassInfoRHS, UnifyMode,
|
|
Unification, UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
goal_info_init(GoalInfo0),
|
|
NonLocals = set_of_var.make_singleton(TypeClassInfoVar),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
|
|
% Note that we could perhaps be more accurate than `ground(shared)',
|
|
% but it shouldn't make any difference.
|
|
TypeClassInfoInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(ConsId, [])]),
|
|
TypeClassInfoVarInst = TypeClassInfoVar - TypeClassInfoInst,
|
|
InstMapDelta = instmap_delta_from_assoc_list([TypeClassInfoVarInst]),
|
|
goal_info_set_instmap_delta(InstMapDelta, GoalInfo1, GoalInfo2),
|
|
goal_info_set_determinism(detism_det, GoalInfo2, GoalInfo),
|
|
|
|
Goal = hlds_goal(GoalExpr, GoalInfo),
|
|
% XXX reset varset and vartypes
|
|
AllGoals = [Goal]
|
|
else
|
|
TypeClassInfoMCA = no,
|
|
new_typeclass_info_var(Constraint, typeclass_info_kind,
|
|
TypeClassInfoVar, _TypeClassInfoVarType, !Info),
|
|
assoc_list.keys(ArgVarsMCAs, ArgVars),
|
|
AllArgVars = [BaseVar | ArgVars],
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
TypeClassInfoRHS =
|
|
rhs_functor(ConsId, is_not_exist_constr, AllArgVars),
|
|
Ground = ground(shared, none_or_default_func),
|
|
ArgMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
list.length(AllArgVars, NumArgs),
|
|
list.duplicate(NumArgs, ArgMode, ArgModes),
|
|
Unification = construct(TypeClassInfoVar, ConsId, AllArgVars, ArgModes,
|
|
construct_dynamically, cell_is_unique, no_construct_sub_info),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
GoalExpr = unify(TypeClassInfoVar, TypeClassInfoRHS, UnifyMode,
|
|
Unification, UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
goal_info_init(GoalInfo0),
|
|
set_of_var.list_to_set([TypeClassInfoVar | AllArgVars], NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
|
|
list.duplicate(NumArgs, Ground, ArgInsts),
|
|
% Note that we could perhaps be more accurate than `ground(shared)',
|
|
% but it shouldn't make any difference.
|
|
InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgs),
|
|
InstResults = inst_test_results(inst_result_is_ground,
|
|
inst_result_does_not_contain_any,
|
|
inst_result_contains_inst_names_known(set.init),
|
|
inst_result_contains_inst_vars_unknown,
|
|
inst_result_contains_types_unknown,
|
|
inst_result_no_type_ctor_propagated),
|
|
% XXX that should be inst_result_contains_types_known(set.init),
|
|
TypeClassInfoInst = bound(unique, InstResults,
|
|
[bound_functor(InstConsId, ArgInsts)]),
|
|
TypeClassInfoVarInst = TypeClassInfoVar - TypeClassInfoInst,
|
|
InstMapDelta = instmap_delta_from_assoc_list([TypeClassInfoVarInst]),
|
|
goal_info_set_instmap_delta(InstMapDelta, GoalInfo1, GoalInfo2),
|
|
goal_info_set_determinism(detism_det, GoalInfo2, GoalInfo),
|
|
|
|
Goal = hlds_goal(GoalExpr, GoalInfo),
|
|
AllGoals = PrevGoals ++ [Goal]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred get_arg_superclass_vars(hlds_class_defn::in, list(mer_type)::in,
|
|
constraint_proof_map::in, existq_tvars::in,
|
|
assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofMap,
|
|
ExistQVars, SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info) :-
|
|
poly_info_get_proof_map(!.Info, ProofMap),
|
|
|
|
poly_info_get_typevarset(!.Info, TVarSet0),
|
|
SuperClasses0 = ClassDefn ^ classdefn_supers,
|
|
ClassVars0 = ClassDefn ^ classdefn_vars,
|
|
ClassTVarSet = ClassDefn ^ classdefn_tvarset,
|
|
tvarset_merge_renaming(TVarSet0, ClassTVarSet, TVarSet1, Renaming),
|
|
poly_info_set_typevarset(TVarSet1, !Info),
|
|
|
|
apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars),
|
|
map.from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
|
|
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming,
|
|
SuperClasses0, SuperClasses1),
|
|
apply_rec_subst_to_prog_constraint_list(TypeSubst,
|
|
SuperClasses1, SuperClasses),
|
|
|
|
poly_info_set_proof_map(SuperClassProofMap, !Info),
|
|
make_typeclass_infos_for_superclasses(SuperClasses, ExistQVars,
|
|
SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info),
|
|
poly_info_set_proof_map(ProofMap, !Info).
|
|
|
|
:- pred make_typeclass_infos_for_superclasses(list(prog_constraint)::in,
|
|
existq_tvars::in, assoc_list(prog_var, maybe(const_struct_arg))::out,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_infos_for_superclasses([], _, [], [], !Info).
|
|
make_typeclass_infos_for_superclasses([Constraint | Constraints], ExistQVars,
|
|
[TypeClassInfoVarMCA | TypeClassInfoVarsMCAs], Goals, !Info) :-
|
|
term.context_init(Context),
|
|
make_typeclass_info_var(Constraint, [], ExistQVars, Context,
|
|
TypeClassInfoVarMCA, HeadGoals, !Info),
|
|
make_typeclass_infos_for_superclasses(Constraints, ExistQVars,
|
|
TypeClassInfoVarsMCAs, TailGoals, !Info),
|
|
Goals = HeadGoals ++ TailGoals.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Produce the typeclass_infos for the existential class constraints
|
|
% for a call or deconstruction unification.
|
|
%
|
|
:- pred make_existq_typeclass_info_vars(list(prog_constraint)::in,
|
|
prog_context::in, list(prog_var)::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_existq_typeclass_info_vars(ExistentialConstraints, Context,
|
|
ExtraTypeClassVars, ExtraGoals, !Info) :-
|
|
poly_info_get_rtti_varmaps(!.Info, OldRttiVarMaps),
|
|
make_typeclass_info_head_vars(do_record_type_info_locns,
|
|
ExistentialConstraints, ExtraTypeClassVars, !Info),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
list.foldl(rtti_reuse_typeclass_info_var, ExtraTypeClassVars,
|
|
RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
|
|
|
|
constraint_list_get_tvars(ExistentialConstraints, TVars0),
|
|
list.sort_and_remove_dups(TVars0, TVars),
|
|
list.foldl2(
|
|
polymorphism_maybe_extract_type_info(OldRttiVarMaps, Context), TVars,
|
|
[], ExtraGoals, !Info).
|
|
|
|
% For code which requires mode reordering, we may have already seen uses
|
|
% of some of the type variables produced by this call. At the point of the
|
|
% use of a type variable that we haven't seen before, we assume that it is
|
|
% unconstrained. If it turns out that the type variable is constrained,
|
|
% and the type_info is contained in a typeclass_info, we need to generate
|
|
% code to extract it here.
|
|
%
|
|
:- pred polymorphism_maybe_extract_type_info(rtti_varmaps::in,
|
|
prog_context::in, tvar::in, list(hlds_goal)::in, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_maybe_extract_type_info(OldRttiVarMaps, Context, TVar,
|
|
!ExtraGoals, !Info) :-
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps),
|
|
( if
|
|
rtti_search_type_info_locn(OldRttiVarMaps, TVar,
|
|
type_info(TypeInfoVar0)),
|
|
rtti_search_type_info_locn(RttiVarMaps, TVar,
|
|
typeclass_info(TypeClassInfoVar, Index))
|
|
then
|
|
polymorphism_extract_type_info(TVar, TypeClassInfoVar, Index, Context,
|
|
NewGoals, TypeInfoVar1, !Info),
|
|
assign_var(TypeInfoVar0, TypeInfoVar1, AssignGoal),
|
|
!:ExtraGoals = NewGoals ++ [AssignGoal | !.ExtraGoals]
|
|
else
|
|
true
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
polymorphism_make_type_info_vars(Types, Context, ExtraVars,
|
|
ExtraGoals, !Info) :-
|
|
polymorphism_do_make_type_info_vars(Types, Context, ExtraVarsMCAs,
|
|
ExtraGoals, !Info),
|
|
assoc_list.keys(ExtraVarsMCAs, ExtraVars).
|
|
|
|
polymorphism_make_type_info_var(Type, Context, ExtraVar, ExtraGoals, !Info) :-
|
|
polymorphism_do_make_type_info_var(Type, Context, ExtraVarMCA,
|
|
ExtraGoals, !Info),
|
|
ExtraVarMCA = ExtraVar - _.
|
|
|
|
:- pred polymorphism_do_make_type_info_vars(list(mer_type)::in,
|
|
term.context::in,
|
|
assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_do_make_type_info_vars([], _, [], [], !Info).
|
|
polymorphism_do_make_type_info_vars([Type | Types], Context,
|
|
VarsMCAs, Goals, !Info) :-
|
|
polymorphism_do_make_type_info_var(Type, Context, HeadVarMCA,
|
|
HeadGoals, !Info),
|
|
polymorphism_do_make_type_info_vars(Types, Context, TailVarsMCAs,
|
|
TailGoals, !Info),
|
|
VarsMCAs = [HeadVarMCA | TailVarsMCAs],
|
|
Goals = HeadGoals ++ TailGoals.
|
|
|
|
:- pred polymorphism_do_make_type_info_var(mer_type::in, term.context::in,
|
|
pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_do_make_type_info_var(Type, Context, VarMCA, ExtraGoals, !Info) :-
|
|
% First handle statically known types (i.e. types which are not
|
|
% type variables).
|
|
( if type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) then
|
|
% This occurs for code where a predicate calls a polymorphic predicate
|
|
% with a type whose type constructor is of variable arity. The
|
|
% transformation we perform is basically the same as in the usual case
|
|
% below, except that we map pred types to pred/0, func types to func/0
|
|
% and tuple types to tuple/0 for the purposes of creating type_infos.
|
|
% To allow univ_to_type to check the type_infos correctly, the actual
|
|
% arity is added to the type_info we create.
|
|
%
|
|
% XXX FIXME (RTTI for higher order impure code)
|
|
% we should not ignore the purity of higher order procs;
|
|
% it should get included in the RTTI.
|
|
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, yes,
|
|
Context, VarMCA, ExtraGoals, !Info)
|
|
else
|
|
(
|
|
( Type = defined_type(_, _, _)
|
|
; Type = builtin_type(_)
|
|
; Type = tuple_type(_, _)
|
|
; Type = higher_order_type(_,_, _, _, _)
|
|
; Type = apply_n_type(_, _, _)
|
|
; Type = kinded_type(_, _)
|
|
),
|
|
type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs),
|
|
% This occurs for code where a predicate calls a polymorphic
|
|
% predicate with a known value of the type variable. The
|
|
% transformation we perform is shown in the comment at the top
|
|
% of the module.
|
|
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, no,
|
|
Context, VarMCA, ExtraGoals, !Info)
|
|
;
|
|
% Now handle the cases of types which are not known statically,
|
|
% i.e. type variables.
|
|
Type = type_variable(TypeVar, _),
|
|
get_type_info_locn(TypeVar, TypeInfoLocn, !Info),
|
|
get_type_info_from_locn(TypeVar, TypeInfoLocn, Context,
|
|
Var, ExtraGoals, !Info),
|
|
VarMCA = Var - no
|
|
)
|
|
).
|
|
|
|
:- pred polymorphism_make_type_info(mer_type::in, type_ctor::in,
|
|
list(mer_type)::in, bool::in, prog_context::in,
|
|
pair(prog_var, maybe(const_struct_arg))::out,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, TypeCtorIsVarArity,
|
|
Context, TypeInfoVarMCA, ExtraGoals, !Info) :-
|
|
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap0),
|
|
( if
|
|
map.search(TypeInfoVarMap0, TypeCtor, TypeCtorVarMap0),
|
|
map.search(TypeCtorVarMap0, TypeArgs, OldTypeInfoVarMCA)
|
|
then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
TypeInfoVarMCA = OldTypeInfoVarMCA,
|
|
ExtraGoals = []
|
|
else
|
|
polymorphism_construct_type_info(Type, TypeCtor, TypeArgs,
|
|
TypeCtorIsVarArity, Context, TypeInfoVar, TypeInfoConstArg,
|
|
ExtraGoals, !Info),
|
|
TypeInfoVarMCA = TypeInfoVar - TypeInfoConstArg,
|
|
% We have to get the type_info_var_map again since the call just above
|
|
% could have added relevant new entries to it.
|
|
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap1),
|
|
( if map.search(TypeInfoVarMap1, TypeCtor, TypeCtorVarMap1) then
|
|
map.det_insert(TypeArgs, TypeInfoVarMCA,
|
|
TypeCtorVarMap1, TypeCtorVarMap),
|
|
map.det_update(TypeCtor, TypeCtorVarMap,
|
|
TypeInfoVarMap1, TypeInfoVarMap)
|
|
else
|
|
TypeCtorVarMap = map.singleton(TypeArgs, TypeInfoVarMCA),
|
|
map.det_insert(TypeCtor, TypeCtorVarMap,
|
|
TypeInfoVarMap1, TypeInfoVarMap)
|
|
),
|
|
poly_info_set_type_info_var_map(TypeInfoVarMap, !Info)
|
|
).
|
|
|
|
:- pred polymorphism_construct_type_info(mer_type::in, type_ctor::in,
|
|
list(mer_type)::in, bool::in, prog_context::in,
|
|
prog_var::out, maybe(const_struct_arg)::out,
|
|
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_construct_type_info(Type, TypeCtor, TypeArgs, TypeCtorIsVarArity,
|
|
Context, Var, MCA, ExtraGoals, !Info) :-
|
|
get_var_maps_snapshot("polymorphism_construct_type_info",
|
|
InitialVarMapsSnapshot, !Info),
|
|
|
|
% Create the typeinfo vars for the arguments.
|
|
polymorphism_do_make_type_info_vars(TypeArgs, Context,
|
|
ArgTypeInfoVarsMCAs, ArgTypeInfoGoals, !Info),
|
|
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
|
|
TypeCtorConsId = type_ctor_info_cons_id(TypeCtor),
|
|
TypeCtorConsIdConstArg = csa_constant(TypeCtorConsId, type_info_type),
|
|
poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
|
|
( if
|
|
map.search(ConstStructVarMap0, TypeCtorConsIdConstArg, OldTypeCtorVar)
|
|
then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
TypeCtorVar = OldTypeCtorVar,
|
|
TypeCtorGoals = [],
|
|
VarSet1 = VarSet0,
|
|
VarTypes1 = VarTypes0,
|
|
RttiVarMaps1 = RttiVarMaps0
|
|
else
|
|
init_const_type_ctor_info_var_from_cons_id(Type, TypeCtorConsId,
|
|
TypeCtorVar, TypeCtorGoal, VarSet0, VarSet1, VarTypes0, VarTypes1,
|
|
RttiVarMaps0, RttiVarMaps1),
|
|
TypeCtorGoals = [TypeCtorGoal],
|
|
map.det_insert(TypeCtorConsIdConstArg, TypeCtorVar,
|
|
ConstStructVarMap0, ConstStructVarMap1),
|
|
poly_info_set_const_struct_var_map(ConstStructVarMap1, !Info)
|
|
),
|
|
|
|
poly_info_set_varset_types_rtti(VarSet1, VarTypes1, RttiVarMaps1, !Info),
|
|
|
|
% The rest of this predicate create code that constructs the second cell
|
|
% of a type_info for Type if we need a second cell for Type. This cell
|
|
% will usually be of the form:
|
|
%
|
|
% TypeInfoVar = type_info(TypeCtorVar, ArgTypeInfoVars...)
|
|
%
|
|
% However, if TypeCtorIsVarArity is true and we are not compiling for
|
|
% the Java backend, then it will be of the form
|
|
%
|
|
% TypeInfoVar = type_info(TypeCtorVar, Arity, ArgTypeInfoVars...)
|
|
%
|
|
% TypeCtorVar should be the variable holding the type_ctor_info for the
|
|
% principal type constructor of Type, and TypeCtorIsVarArity should be
|
|
% true iff the type constructor it represents has a variable arity.
|
|
%
|
|
% ArgTypeInfoVars should be variables holding the type_infos (or
|
|
% type_ctor_infos for zero-arity types) of the argument types of Type.
|
|
%
|
|
% The returned Var will be bound to the type_info cell of Type if such
|
|
% a cell had to be allocated, and to the type_ctor_info of Type's only
|
|
% type constructor if it didn't.
|
|
%
|
|
% NOTE: the special handling for the java backend must be kept
|
|
% consistent with:
|
|
% rtti_to_mlds.gen_type_info_defn/6
|
|
% java/runtime/TypeInfo_Struct.java
|
|
|
|
% Determine if we need to explicitly pass the arity.
|
|
(
|
|
TypeCtorIsVarArity = no,
|
|
PassArity = no
|
|
;
|
|
TypeCtorIsVarArity = yes,
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
get_target(Globals, Target),
|
|
(
|
|
Target = target_java,
|
|
PassArity = no
|
|
;
|
|
( Target = target_c
|
|
; Target = target_csharp
|
|
; Target = target_erlang
|
|
),
|
|
PassArity = yes
|
|
)
|
|
),
|
|
|
|
( if
|
|
% Unfortunately, if the type's type constructor has variable arity,
|
|
% we cannot use a one-cell representation for that type.
|
|
PassArity = no,
|
|
ArgTypeInfoVarsMCAs = []
|
|
then
|
|
% We do not need a second cell for a separate typeinfo; we will use
|
|
% the type_ctor_info as the type_info.
|
|
|
|
% Since this type_ctor_info is pretending to be a type_info,
|
|
% we need to adjust its type. We handle type_ctor_info_const cons_ids
|
|
% specially to make sure that this causes no problems.
|
|
TypeInfoType = type_info_type,
|
|
Var = TypeCtorVar,
|
|
TypeCtorConstArg = csa_constant(TypeCtorConsId, type_info_type),
|
|
MCA = yes(TypeCtorConstArg),
|
|
ExtraGoals = ArgTypeInfoGoals ++ TypeCtorGoals,
|
|
update_var_type(TypeCtorVar, TypeInfoType, VarTypes1, VarTypes),
|
|
poly_info_set_varset_types(VarSet1, VarTypes, !Info)
|
|
else
|
|
% We do need a second cell for a separate typeinfo.
|
|
Cell = type_info_cell(TypeCtor),
|
|
ConsId = cell_cons_id(Cell),
|
|
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb0),
|
|
const_struct_db_get_poly_enabled(ConstStructDb0, Enabled),
|
|
( if
|
|
Enabled = yes,
|
|
all_are_const_struct_args(ArgTypeInfoVarsMCAs,
|
|
ArgTypeInfoConstArgs)
|
|
then
|
|
TypeCtorConstArg = csa_constant(TypeCtorConsId, type_info_type),
|
|
TypeCtorInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(TypeCtorConsId, [])]),
|
|
list.map(get_inst_of_const_struct_arg(ConstStructDb0),
|
|
ArgTypeInfoConstArgs, ArgTypeInfoInsts),
|
|
(
|
|
PassArity = yes,
|
|
list.length(ArgTypeInfoVarsMCAs, ActualArity),
|
|
ArityConstArg = csa_constant(int_const(ActualArity), int_type),
|
|
ArityInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(int_const(ActualArity), [])]),
|
|
StructConstArgs =
|
|
[TypeCtorConstArg, ArityConstArg | ArgTypeInfoConstArgs],
|
|
StructArgInsts = [TypeCtorInst, ArityInst | ArgTypeInfoInsts]
|
|
;
|
|
PassArity = no,
|
|
StructConstArgs = [TypeCtorConstArg | ArgTypeInfoConstArgs],
|
|
StructArgInsts = [TypeCtorInst | ArgTypeInfoInsts]
|
|
),
|
|
StructType = type_info_type,
|
|
list.length(StructConstArgs, NumArgs),
|
|
InstConsId = cell_inst_cons_id(Cell, NumArgs),
|
|
StructInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(InstConsId, StructArgInsts)]),
|
|
|
|
ConstStruct = const_struct(ConsId, StructConstArgs,
|
|
StructType, StructInst),
|
|
lookup_insert_const_struct(ConstStruct, ConstNum,
|
|
ConstStructDb0, ConstStructDb),
|
|
MCA = yes(csa_const_struct(ConstNum)),
|
|
poly_info_set_const_struct_db(ConstStructDb, !Info),
|
|
|
|
set_var_maps_snapshot("maybe_init_second_cell",
|
|
InitialVarMapsSnapshot, !Info),
|
|
|
|
new_type_info_var(Type, type_info, Var, !Info),
|
|
Unification = construct(Var, type_info_const(ConstNum),
|
|
[], [], construct_statically, cell_is_shared,
|
|
no_construct_sub_info),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
TypeInfoRHS = rhs_functor(type_info_const(ConstNum),
|
|
is_not_exist_constr, []),
|
|
Unify = unify(Var, TypeInfoRHS, UnifyMode, Unification,
|
|
UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
NonLocals = set_of_var.make_singleton(Var),
|
|
% Note that we could be more accurate than `ground(shared)',
|
|
% but it shouldn't make any difference.
|
|
VarInst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(InstConsId, [])]),
|
|
InstMapDelta = instmap_delta_from_assoc_list([Var - VarInst]),
|
|
goal_info_init(NonLocals, InstMapDelta, detism_det, purity_pure,
|
|
GoalInfo),
|
|
TypeInfoGoal = hlds_goal(Unify, GoalInfo),
|
|
ExtraGoals = [TypeInfoGoal]
|
|
else
|
|
assoc_list.keys(ArgTypeInfoVarsMCAs, ArgTypeInfoVars),
|
|
(
|
|
PassArity = yes,
|
|
list.length(ArgTypeInfoVars, ActualArity),
|
|
get_poly_const(ActualArity, ArityVar, ArityGoals, !Info),
|
|
% The call get_poly_const may (and probably will) allocate
|
|
% a variable, so VarSet1, VarTypes1 and RttiVarMaps1 are
|
|
% all out of date.
|
|
poly_info_get_varset(!.Info, VarSet2),
|
|
poly_info_get_var_types(!.Info, VarTypes2),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps2),
|
|
init_type_info_var(Type,
|
|
[TypeCtorVar, ArityVar | ArgTypeInfoVars],
|
|
no, Var, TypeInfoGoal,
|
|
VarSet2, VarSet, VarTypes2, VarTypes,
|
|
RttiVarMaps2, RttiVarMaps),
|
|
ExtraGoals = TypeCtorGoals ++ ArityGoals ++ ArgTypeInfoGoals
|
|
++ [TypeInfoGoal]
|
|
;
|
|
PassArity = no,
|
|
init_type_info_var(Type, [TypeCtorVar | ArgTypeInfoVars],
|
|
no, Var, TypeInfoGoal,
|
|
VarSet1, VarSet, VarTypes1, VarTypes,
|
|
RttiVarMaps1, RttiVarMaps),
|
|
ExtraGoals = TypeCtorGoals ++ ArgTypeInfoGoals ++
|
|
[TypeInfoGoal]
|
|
),
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps,
|
|
!Info),
|
|
MCA = no
|
|
)
|
|
).
|
|
|
|
init_type_info_var(Type, ArgVars, MaybePreferredVar, TypeInfoVar, TypeInfoGoal,
|
|
!VarSet, !VarTypes, !RttiVarMaps) :-
|
|
type_to_ctor_det(Type, TypeCtor),
|
|
Cell = type_info_cell(TypeCtor),
|
|
ConsId = cell_cons_id(Cell),
|
|
do_init_type_info_var(Type, Cell, ConsId, ArgVars, MaybePreferredVar,
|
|
TypeInfoVar, TypeInfoGoal, !VarSet, !VarTypes, !RttiVarMaps).
|
|
|
|
:- pred do_init_type_info_var(mer_type::in, polymorphism_cell::in, cons_id::in,
|
|
list(prog_var)::in, maybe(prog_var)::in, prog_var::out, hlds_goal::out,
|
|
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
|
|
rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
do_init_type_info_var(Type, Cell, ConsId, ArgVars, MaybePreferredVar,
|
|
TypeInfoVar, TypeInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
|
|
TypeInfoRHS = rhs_functor(ConsId, is_not_exist_constr, ArgVars),
|
|
% Introduce a new variable.
|
|
(
|
|
MaybePreferredVar = yes(TypeInfoVar)
|
|
;
|
|
MaybePreferredVar = no,
|
|
new_type_info_var_raw(Type, type_info, TypeInfoVar,
|
|
!VarSet, !VarTypes, !RttiVarMaps)
|
|
),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
Ground = ground(shared, none_or_default_func),
|
|
ArgMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
list.length(ArgVars, NumArgVars),
|
|
list.duplicate(NumArgVars, ArgMode, ArgModes),
|
|
Unification = construct(TypeInfoVar, ConsId, ArgVars, ArgModes,
|
|
construct_dynamically, cell_is_unique, no_construct_sub_info),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
Unify = unify(TypeInfoVar, TypeInfoRHS, UnifyMode, Unification,
|
|
UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
set_of_var.list_to_set([TypeInfoVar | ArgVars], NonLocals),
|
|
list.duplicate(NumArgVars, Ground, ArgInsts),
|
|
% Note that we could perhaps be more accurate than `ground(shared)',
|
|
% but it shouldn't make any difference.
|
|
InstConsId = cell_inst_cons_id(Cell, NumArgVars),
|
|
InstResults = inst_test_results(inst_result_is_ground,
|
|
inst_result_does_not_contain_any,
|
|
inst_result_contains_inst_names_known(set.init),
|
|
inst_result_contains_inst_vars_unknown,
|
|
inst_result_contains_types_unknown,
|
|
inst_result_no_type_ctor_propagated),
|
|
TypeInfoVarInst = bound(unique, InstResults,
|
|
[bound_functor(InstConsId, ArgInsts)]),
|
|
InstMapDelta = instmap_delta_from_assoc_list(
|
|
[TypeInfoVar - TypeInfoVarInst]),
|
|
goal_info_init(NonLocals, InstMapDelta, detism_det, purity_pure, GoalInfo),
|
|
TypeInfoGoal = hlds_goal(Unify, GoalInfo).
|
|
|
|
init_const_type_ctor_info_var(Type, TypeCtor, TypeCtorInfoVar,
|
|
ConsId, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
|
|
ConsId = type_ctor_info_cons_id(TypeCtor),
|
|
init_const_type_ctor_info_var_from_cons_id(Type, ConsId,
|
|
TypeCtorInfoVar, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps).
|
|
|
|
:- pred init_const_type_ctor_info_var_from_cons_id(mer_type::in, cons_id::in,
|
|
prog_var::out, hlds_goal::out, prog_varset::in, prog_varset::out,
|
|
vartypes::in, vartypes::out, rtti_varmaps::in, rtti_varmaps::out) is det.
|
|
|
|
init_const_type_ctor_info_var_from_cons_id(Type, ConsId,
|
|
TypeCtorInfoVar, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
|
|
% Introduce a new variable.
|
|
new_type_info_var_raw(Type, type_ctor_info, TypeCtorInfoVar,
|
|
!VarSet, !VarTypes, !RttiVarMaps),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
TypeInfoRHS = rhs_functor(ConsId, is_not_exist_constr, []),
|
|
Unification = construct(TypeCtorInfoVar, ConsId, [], [],
|
|
construct_dynamically, cell_is_shared, no_construct_sub_info),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
Unify = unify(TypeCtorInfoVar, TypeInfoRHS, UnifyMode,
|
|
Unification, UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
NonLocals = set_of_var.make_singleton(TypeCtorInfoVar),
|
|
InstmapDelta = instmap_delta_bind_var(TypeCtorInfoVar),
|
|
goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure, GoalInfo),
|
|
TypeCtorInfoGoal = hlds_goal(Unify, GoalInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred make_head_vars(list(tvar)::in, tvarset::in,
|
|
list(prog_var)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
make_head_vars([], _, [], !Info).
|
|
make_head_vars([TypeVar | TypeVars], TypeVarSet, TypeInfoVars, !Info) :-
|
|
poly_info_get_tvar_kind_map(!.Info, TVarKindMap),
|
|
get_tvar_kind(TVarKindMap, TypeVar, Kind),
|
|
Type = type_variable(TypeVar, Kind),
|
|
new_type_info_var(Type, type_info, Var, !Info),
|
|
( if varset.search_name(TypeVarSet, TypeVar, TypeVarName) then
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
VarName = "TypeInfo_for_" ++ TypeVarName,
|
|
varset.name_var(Var, VarName, VarSet0, VarSet),
|
|
poly_info_set_varset(VarSet, !Info)
|
|
else
|
|
true
|
|
),
|
|
make_head_vars(TypeVars, TypeVarSet, TypeInfoVars1, !Info),
|
|
TypeInfoVars = [Var | TypeInfoVars1].
|
|
|
|
:- pred new_type_info_var(mer_type::in, type_info_kind::in,
|
|
prog_var::out, poly_info::in, poly_info::out) is det.
|
|
|
|
new_type_info_var(Type, Kind, Var, !Info) :-
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
new_type_info_var_raw(Type, Kind, Var, VarSet0, VarSet,
|
|
VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info).
|
|
|
|
new_type_info_var_raw(Type, Kind, Var, !VarSet, !VarTypes, !RttiVarMaps) :-
|
|
% Introduce new variable.
|
|
varset.new_var(Var, !VarSet),
|
|
term.var_to_int(Var, VarNum),
|
|
string.int_to_string(VarNum, VarNumStr),
|
|
(
|
|
Kind = type_info,
|
|
Prefix = "TypeInfo_",
|
|
rtti_det_insert_type_info_type(Var, Type, !RttiVarMaps)
|
|
;
|
|
Kind = type_ctor_info,
|
|
Prefix = "TypeCtorInfo_"
|
|
|
|
% XXX Perhaps we should record the variables holding
|
|
% type_ctor_infos in the rtti_varmaps somewhere.
|
|
),
|
|
Name = Prefix ++ VarNumStr,
|
|
varset.name_var(Var, Name, !VarSet),
|
|
add_var_type(Var, type_info_type, !VarTypes).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred get_type_info_locn(tvar::in, type_info_locn::out, poly_info::in,
|
|
poly_info::out) is det.
|
|
|
|
get_type_info_locn(TypeVar, TypeInfoLocn, !Info) :-
|
|
% If we have already allocated a location for this type_info, then all
|
|
% we need to do is to extract the type_info variable from its location.
|
|
( if
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_search_type_info_locn(RttiVarMaps0, TypeVar, TypeInfoLocnPrime)
|
|
then
|
|
TypeInfoLocn = TypeInfoLocnPrime
|
|
else
|
|
% Otherwise, we need to create a new type_info variable, and set the
|
|
% location for this type variable to be that type_info variable.
|
|
%
|
|
% This is wrong if the type variable is one of the existentially
|
|
% quantified variables of a called predicate and the variable occurs
|
|
% in an existential typeclass constraint. In that case the type_info
|
|
% will be stored in the typeclass_info variable produced by the
|
|
% predicate, not in a type_info variable. maybe_extract_type_info
|
|
% will fix this up when the typeclass_info is created.
|
|
|
|
poly_info_get_tvar_kind_map(!.Info, TVarKindMap),
|
|
get_tvar_kind(TVarKindMap, TypeVar, Kind),
|
|
Type = type_variable(TypeVar, Kind),
|
|
new_type_info_var(Type, type_info, Var, !Info),
|
|
TypeInfoLocn = type_info(Var),
|
|
% Since the call to new_type_info_var above may update the rtti
|
|
% varmaps, we have to get them again here; we can't use RttiVarMaps0.
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps1),
|
|
rtti_det_insert_type_info_locn(TypeVar, TypeInfoLocn,
|
|
RttiVarMaps1, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
|
|
).
|
|
|
|
% Generate code to get the value of a type variable.
|
|
%
|
|
:- pred get_type_info_from_locn(tvar::in, type_info_locn::in, prog_context::in,
|
|
prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
get_type_info_from_locn(TypeVar, TypeInfoLocn, Context, Var, ExtraGoals,
|
|
!Info) :-
|
|
(
|
|
% If the typeinfo is available in a variable, just use it.
|
|
TypeInfoLocn = type_info(TypeInfoVar),
|
|
Var = TypeInfoVar,
|
|
ExtraGoals = []
|
|
;
|
|
% If the typeinfo is in a typeclass_info, then we need to extract it
|
|
% before using it.
|
|
TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
|
|
polymorphism_extract_type_info(TypeVar, TypeClassInfoVar, Index,
|
|
Context, ExtraGoals, Var, !Info)
|
|
).
|
|
|
|
:- pred polymorphism_extract_type_info(tvar::in, prog_var::in, int::in,
|
|
prog_context::in, list(hlds_goal)::out, prog_var::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_extract_type_info(TypeVar, TypeClassInfoVar, Index, Context,
|
|
Goals, TypeInfoVar, !Info) :-
|
|
get_poly_const(Index, IndexVar, IndexGoals, !Info),
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
poly_info_get_tvar_kind_map(!.Info, TVarKindMap),
|
|
get_tvar_kind(TVarKindMap, TypeVar, Kind),
|
|
IndexIntOrVar = iov_var(IndexVar),
|
|
gen_extract_type_info(ModuleInfo, TypeVar, Kind, TypeClassInfoVar,
|
|
IndexIntOrVar, Context, ExtractGoals, TypeInfoVar,
|
|
VarSet0, VarSet, VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
|
|
Goals = IndexGoals ++ ExtractGoals,
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info).
|
|
|
|
gen_extract_type_info(ModuleInfo, TypeVar, Kind, TypeClassInfoVar,
|
|
IndexIntOrVar, Context, Goals, TypeInfoVar,
|
|
!VarSet, !VarTypes, !RttiVarMaps) :-
|
|
(
|
|
IndexIntOrVar = iov_int(Index),
|
|
% We cannot call get_poly_const since we don't have a poly_info.
|
|
make_int_const_construction_alloc(Index, yes("TypeInfoIndex"),
|
|
IndexGoal, IndexVar, !VarSet, !VarTypes),
|
|
IndexGoals = [IndexGoal]
|
|
;
|
|
IndexIntOrVar = iov_var(IndexVar),
|
|
IndexGoals = []
|
|
),
|
|
Type = type_variable(TypeVar, Kind),
|
|
new_type_info_var_raw(Type, type_info, TypeInfoVar,
|
|
!VarSet, !VarTypes, !RttiVarMaps),
|
|
goal_util.generate_simple_call(ModuleInfo, mercury_private_builtin_module,
|
|
"type_info_from_typeclass_info", pf_predicate, only_mode,
|
|
detism_det, purity_pure, [TypeClassInfoVar, IndexVar, TypeInfoVar], [],
|
|
instmap_delta_bind_var(TypeInfoVar), Context,
|
|
CallGoal),
|
|
Goals = IndexGoals ++ [CallGoal].
|
|
|
|
:- pred get_poly_const(int::in, prog_var::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
get_poly_const(IntConst, IntVar, Goals, !Info) :-
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
|
|
poly_info_get_int_const_map(!.Info, IntConstMap0),
|
|
( if map.search(IntConstMap0, IntConst, IntVarPrime) then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
IntVar = IntVarPrime,
|
|
Goals = []
|
|
else
|
|
make_int_const_construction_alloc(IntConst,
|
|
yes("PolyConst" ++ string.int_to_string(IntConst)),
|
|
Goal, IntVar, VarSet0, VarSet, VarTypes0, VarTypes),
|
|
map.det_insert(IntConst, IntVar, IntConstMap0, IntConstMap),
|
|
poly_info_set_int_const_map(IntConstMap, !Info),
|
|
poly_info_set_varset_types(VarSet, VarTypes, !Info),
|
|
Goals = [Goal]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Usually when we call make_typeclass_info_head_var, we want to record
|
|
% the type_info_locn for each constrained type var so that later goals
|
|
% will know where to get the type_info from. However, when setting up
|
|
% head vars for existential constraints on the predicate/function we
|
|
% are processing, we assume that the type_infos will be produced
|
|
% somewhere else in the goal. In this case, we don't want to record
|
|
% the type_info_locns (if we did, then the code to actually produce the
|
|
% type_info will just try to get it from here, which would be a mode
|
|
% error).
|
|
%
|
|
:- type record_type_info_locns
|
|
---> do_record_type_info_locns
|
|
; do_not_record_type_info_locns.
|
|
|
|
% Create a head var for each class constraint.
|
|
%
|
|
:- pred make_typeclass_info_head_vars(record_type_info_locns::in,
|
|
list(prog_constraint)::in, list(prog_var)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_head_vars(RecordLocns, Constraints, ExtraHeadVars,
|
|
!Info) :-
|
|
list.map_foldl(make_typeclass_info_head_var(RecordLocns), Constraints,
|
|
ExtraHeadVars, !Info).
|
|
|
|
:- pred make_typeclass_info_head_var(record_type_info_locns::in,
|
|
prog_constraint::in, prog_var::out, poly_info::in, poly_info::out) is det.
|
|
|
|
make_typeclass_info_head_var(RecordLocns, Constraint, TypeClassInfoVar,
|
|
!Info) :-
|
|
( if
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
|
|
OldTypeClassInfoVar)
|
|
then
|
|
TypeClassInfoVar = OldTypeClassInfoVar
|
|
else
|
|
% Make a new variable to contain the dictionary for this typeclass
|
|
% constraint.
|
|
new_typeclass_info_var(Constraint, typeclass_info_kind,
|
|
TypeClassInfoVar, _TypeClassInfoVarType, !Info),
|
|
(
|
|
RecordLocns = do_record_type_info_locns,
|
|
record_constraint_type_info_locns(Constraint, TypeClassInfoVar,
|
|
!Info)
|
|
;
|
|
RecordLocns = do_not_record_type_info_locns
|
|
)
|
|
).
|
|
|
|
:- pred record_constraint_type_info_locns(prog_constraint::in, prog_var::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
record_constraint_type_info_locns(Constraint, ExtraHeadVar, !Info) :-
|
|
poly_info_get_module_info(!.Info, ModuleInfo),
|
|
|
|
% Work out how many superclasses the class has.
|
|
Constraint = constraint(ClassName, ClassTypes),
|
|
list.length(ClassTypes, ClassArity),
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
module_info_get_class_table(ModuleInfo, ClassTable),
|
|
map.lookup(ClassTable, ClassId, ClassDefn),
|
|
SuperClasses = ClassDefn ^ classdefn_supers,
|
|
list.length(SuperClasses, NumSuperClasses),
|
|
|
|
% Find all the type variables in the constraint, and remember what
|
|
% index they appear in the typeclass info.
|
|
|
|
% The first type_info will be just after the superclass infos.
|
|
First = NumSuperClasses + 1,
|
|
Last = NumSuperClasses + ClassArity,
|
|
assoc_list.from_corresponding_lists(ClassTypes, First `..` Last,
|
|
IndexedClassTypes),
|
|
|
|
% Work out which type variables we haven't seen before, or which we
|
|
% assumed earlier would be produced in a type_info (this can happen for
|
|
% code which needs mode reordering and which calls existentially quantified
|
|
% predicates or deconstructs existentially quantified terms).
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
NewTVarAndIndex =
|
|
( pred(TVarAndIndex::out) is nondet :-
|
|
list.member(Type - Index, IndexedClassTypes),
|
|
type_vars(Type, TypeVars),
|
|
list.member(TypeVar, TypeVars),
|
|
( if
|
|
rtti_search_type_info_locn(RttiVarMaps0, TypeVar, TypeInfoLocn)
|
|
then
|
|
TypeInfoLocn = type_info(_)
|
|
else
|
|
true
|
|
),
|
|
TVarAndIndex = TypeVar - Index
|
|
),
|
|
solutions(NewTVarAndIndex, NewClassTypeVars),
|
|
|
|
% Make an entry in the TypeInfo locations map for each new type variable.
|
|
% The type variable can be found at the previously calculated offset
|
|
% with the new typeclass_info.
|
|
MakeEntry =
|
|
( pred(IndexedTypeVar::in, R0::in, R::out) is det :-
|
|
IndexedTypeVar = TheTypeVar - Index,
|
|
Location = typeclass_info(ExtraHeadVar, Index),
|
|
rtti_set_type_info_locn(TheTypeVar, Location, R0, R)
|
|
),
|
|
list.foldl(MakeEntry, NewClassTypeVars, RttiVarMaps0, RttiVarMaps),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
|
|
|
|
:- type tci_var_kind
|
|
---> base_typeclass_info_kind
|
|
; typeclass_info_kind.
|
|
|
|
:- pred new_typeclass_info_var(prog_constraint::in, tci_var_kind::in,
|
|
prog_var::out, mer_type::out, poly_info::in, poly_info::out) is det.
|
|
|
|
new_typeclass_info_var(Constraint, VarKind, Var, VarType, !Info) :-
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
poly_info_get_var_types(!.Info, VarTypes0),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
|
|
Constraint = constraint(ClassName, _),
|
|
ClassNameString = unqualify_name(ClassName),
|
|
|
|
% Introduce new variable.
|
|
varset.new_var(Var, VarSet0, VarSet1),
|
|
(
|
|
VarKind = base_typeclass_info_kind,
|
|
Name = "BaseTypeClassInfo_for_" ++ ClassNameString
|
|
;
|
|
VarKind = typeclass_info_kind,
|
|
Name = "TypeClassInfo_for_" ++ ClassNameString
|
|
),
|
|
varset.name_var(Var, Name, VarSet1, VarSet),
|
|
build_typeclass_info_type(Constraint, VarType),
|
|
add_var_type(Var, VarType, VarTypes0, VarTypes),
|
|
rtti_det_insert_typeclass_info_var(Constraint, Var,
|
|
RttiVarMaps0, RttiVarMaps),
|
|
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info).
|
|
|
|
build_typeclass_info_type(_Constraint, DictionaryType) :-
|
|
PrivateBuiltin = mercury_private_builtin_module,
|
|
TypeclassInfoTypeName = qualified(PrivateBuiltin, "typeclass_info"),
|
|
DictionaryType = defined_type(TypeclassInfoTypeName, [], kind_star).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
type_is_typeclass_info(TypeClassInfoType) :-
|
|
type_to_ctor(TypeClassInfoType, TypeCtor),
|
|
TypeCtor = type_ctor(qualified(ModuleName, "typeclass_info"), 0),
|
|
ModuleName = mercury_private_builtin_module.
|
|
|
|
type_is_type_info_or_ctor_type(TypeInfoType) :-
|
|
type_to_ctor_and_args(TypeInfoType, TypeCtor, []),
|
|
TypeCtor = type_ctor(qualified(ModuleName, TypeName), 0),
|
|
ModuleName = mercury_private_builtin_module,
|
|
( TypeName = "type_info"
|
|
; TypeName = "type_ctor_info"
|
|
).
|
|
|
|
build_type_info_type(Type, TypeInfoType) :-
|
|
% XXX TypeInfoType = type_ctor_info_type.
|
|
( if type_has_variable_arity_ctor(Type, _, _) then
|
|
% We cannot use a plain type_ctor_info because we need to
|
|
% record the arity.
|
|
TypeInfoType = type_info_type
|
|
else if type_to_ctor_and_args(Type, _Ctor, Args) then
|
|
(
|
|
Args = [],
|
|
TypeInfoType = type_ctor_info_type
|
|
;
|
|
Args = [_ | _],
|
|
TypeInfoType = type_info_type
|
|
)
|
|
else
|
|
% The type is variable, which means we have a type_info for it.
|
|
% That type_info may actually be a type_ctor_info, but the code
|
|
% of the current predicate won't treat it as such.
|
|
TypeInfoType = type_info_type
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
post_copy_polymorphism(ExistsCastPredIds, !ModuleInfo) :-
|
|
list.foldl(introduce_exists_casts_poly, ExistsCastPredIds, !ModuleInfo),
|
|
|
|
% Expand the bodies of all class methods. Class methods for imported
|
|
% classes are only expanded if we are performing type specialization,
|
|
% so that method lookups for imported classes can be optimized.
|
|
%
|
|
% The expansion involves inserting a class_method_call with the appropriate
|
|
% arguments, which is responsible for extracting the appropriate part
|
|
% of the dictionary.
|
|
|
|
module_info_get_class_table(!.ModuleInfo, ClassMap),
|
|
module_info_get_name(!.ModuleInfo, ModuleName),
|
|
map.keys(ClassMap, ClassIds0),
|
|
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, user_guided_type_specialization,
|
|
TypeSpec),
|
|
(
|
|
TypeSpec = no,
|
|
% Don't expand classes from other modules.
|
|
list.filter(class_id_is_from_given_module(ModuleName),
|
|
ClassIds0, ClassIds)
|
|
;
|
|
TypeSpec = yes,
|
|
ClassIds = ClassIds0
|
|
),
|
|
map.apply_to_list(ClassIds, ClassMap, ClassDefns),
|
|
list.foldl(expand_class_method_bodies_in_defn, ClassDefns, !ModuleInfo).
|
|
|
|
:- pred class_id_is_from_given_module(module_name::in, class_id::in)
|
|
is semidet.
|
|
|
|
class_id_is_from_given_module(ModuleName, ClassId) :-
|
|
ClassId = class_id(qualified(ModuleName, _), _).
|
|
|
|
:- pred expand_class_method_bodies_in_defn(hlds_class_defn::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
expand_class_method_bodies_in_defn(ClassDefn, !ModuleInfo) :-
|
|
Interface = ClassDefn ^ classdefn_hlds_interface,
|
|
list.foldl2(expand_class_method_body, Interface, 1, _, !ModuleInfo).
|
|
|
|
:- pred expand_class_method_body(pred_proc_id::in, int::in, int::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
expand_class_method_body(ClassProc, !ProcNum, !ModuleInfo) :-
|
|
ClassProc = proc(PredId, ProcId),
|
|
module_info_get_preds(!.ModuleInfo, PredTable0),
|
|
map.lookup(PredTable0, PredId, PredInfo0),
|
|
pred_info_get_proc_table(PredInfo0, ProcTable0),
|
|
|
|
% XXX Looking up the proc_info for ProcId can fail here because
|
|
% post_typecheck.m deletes proc_ids corresponding to indistinguishable
|
|
% modes from the proc_table but does *not* delete any references to those
|
|
% proc_ids from the class table.
|
|
( if map.search(ProcTable0, ProcId, ProcInfo0) then
|
|
% Find which of the constraints on the pred is the one introduced
|
|
% because it is a class method.
|
|
pred_info_get_class_context(PredInfo0, ClassContext),
|
|
( if ClassContext = constraints([Head | _], _) then
|
|
InstanceConstraint = Head
|
|
else
|
|
unexpected($pred, "class method is not constrained")
|
|
),
|
|
|
|
proc_info_get_rtti_varmaps(ProcInfo0, RttiVarMaps),
|
|
rtti_lookup_typeclass_info_var(RttiVarMaps, InstanceConstraint,
|
|
TypeClassInfoVar),
|
|
|
|
proc_info_get_headvars(ProcInfo0, HeadVars0),
|
|
proc_info_get_argmodes(ProcInfo0, Modes0),
|
|
proc_info_get_declared_determinism(ProcInfo0, MaybeDetism0),
|
|
(
|
|
MaybeDetism0 = yes(Detism)
|
|
;
|
|
MaybeDetism0 = no,
|
|
% Omitting the determinism for a method is not allowed.
|
|
% But make_hlds will have already detected and reported the error.
|
|
% So here we can just pick some value at random; hopefully
|
|
% something that won't cause flow-on errors. We also mark
|
|
% the predicate as invalid, also to avoid flow-on errors.
|
|
Detism = detism_non,
|
|
module_info_make_pred_id_invalid(PredId, !ModuleInfo)
|
|
),
|
|
|
|
% Work out which argument corresponds to the constraint which is
|
|
% introduced because this is a class method, then delete it
|
|
% from the list of args to the class_method_call. That variable becomes
|
|
% the "dictionary" variable for the class_method_call.
|
|
% (cf. the closure for a higher order call).
|
|
( if
|
|
list.index1_of_first_occurrence(HeadVars0, TypeClassInfoVar, N),
|
|
delete_nth(HeadVars0, N, HeadVarsPrime),
|
|
delete_nth(Modes0, N, ModesPrime)
|
|
then
|
|
HeadVars = HeadVarsPrime,
|
|
Modes = ModesPrime
|
|
else
|
|
unexpected($pred, "typeclass_info var not found")
|
|
),
|
|
|
|
InstanceConstraint = constraint(ClassName, InstanceArgs),
|
|
list.length(InstanceArgs, InstanceArity),
|
|
pred_info_get_simple_call_id(PredInfo0, SimpleCallId),
|
|
BodyGoalExpr = generic_call(
|
|
class_method(TypeClassInfoVar, !.ProcNum,
|
|
class_id(ClassName, InstanceArity), SimpleCallId),
|
|
HeadVars, Modes, arg_reg_types_unset, Detism),
|
|
|
|
% Make the goal info for the call.
|
|
set_of_var.list_to_set(HeadVars0, NonLocals),
|
|
instmap_delta_from_mode_list(!.ModuleInfo, HeadVars0, Modes0,
|
|
InstmapDelta),
|
|
pred_info_get_purity(PredInfo0, Purity),
|
|
pred_info_get_context(PredInfo0, Context),
|
|
goal_info_init(NonLocals, InstmapDelta, Detism, Purity, Context,
|
|
GoalInfo),
|
|
BodyGoal = hlds_goal(BodyGoalExpr, GoalInfo),
|
|
|
|
proc_info_set_goal(BodyGoal, ProcInfo0, ProcInfo),
|
|
map.det_update(ProcId, ProcInfo, ProcTable0, ProcTable),
|
|
pred_info_set_proc_table(ProcTable, PredInfo0, PredInfo1),
|
|
% XXX STATUS
|
|
( if pred_info_is_imported(PredInfo1) then
|
|
pred_info_set_status(pred_status(status_opt_imported),
|
|
PredInfo1, PredInfo)
|
|
else
|
|
PredInfo = PredInfo1
|
|
),
|
|
|
|
map.det_update(PredId, PredInfo, PredTable0, PredTable),
|
|
module_info_set_preds(PredTable, !ModuleInfo)
|
|
else
|
|
true
|
|
),
|
|
!:ProcNum = !.ProcNum + 1.
|
|
|
|
:- pred delete_nth(list(T)::in, int::in, list(T)::out) is semidet.
|
|
|
|
delete_nth([X | Xs], N, Result) :-
|
|
( if N > 1 then
|
|
delete_nth(Xs, N - 1, ResultTail),
|
|
Result = [X | ResultTail]
|
|
else
|
|
Result = Xs
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- func get_constrained_vars(prog_constraint) = list(tvar).
|
|
|
|
get_constrained_vars(Constraint) = CVars :-
|
|
Constraint = constraint(_, CTypes),
|
|
type_vars_list(CTypes, CVars).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred all_are_const_struct_args(
|
|
assoc_list(prog_var, maybe(const_struct_arg))::in,
|
|
list(const_struct_arg)::out) is semidet.
|
|
|
|
all_are_const_struct_args([], []).
|
|
all_are_const_struct_args([VarMCA | VarsMCAs], [ConstArg | ConstArgs]) :-
|
|
VarMCA = _Var - MCA,
|
|
MCA = yes(ConstArg),
|
|
all_are_const_struct_args(VarsMCAs, ConstArgs).
|
|
|
|
:- pred get_inst_of_const_struct_arg(const_struct_db::in, const_struct_arg::in,
|
|
mer_inst::out) is det.
|
|
|
|
get_inst_of_const_struct_arg(ConstStructDb, ConstArg, Inst) :-
|
|
(
|
|
ConstArg = csa_constant(ConsId, _),
|
|
Inst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(ConsId, [])])
|
|
;
|
|
ConstArg = csa_const_struct(StructNum),
|
|
lookup_const_struct_num(ConstStructDb, StructNum, Struct),
|
|
Struct = const_struct(_, _, _, Inst)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred materialize_base_typeclass_info_var(prog_constraint::in, cons_id::in,
|
|
prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
materialize_base_typeclass_info_var(Constraint, ConsId, Var, Goals, !Info) :-
|
|
poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
|
|
build_typeclass_info_type(Constraint, ConstArgType),
|
|
ConstArg = csa_constant(ConsId, ConstArgType),
|
|
( if map.search(ConstStructVarMap0, ConstArg, OldVar) then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
Var = OldVar,
|
|
Goals = []
|
|
else
|
|
new_typeclass_info_var(Constraint, base_typeclass_info_kind, Var,
|
|
_VarType, !Info),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
RHS = rhs_functor(ConsId, is_not_exist_constr, []),
|
|
Unification = construct(Var, ConsId, [], [],
|
|
construct_dynamically, cell_is_shared, no_construct_sub_info),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
Unify = unify(Var, RHS, UnifyMode, Unification, UnifyContext),
|
|
|
|
% Create the unification goal.
|
|
NonLocals = set_of_var.make_singleton(Var),
|
|
InstmapDelta = instmap_delta_bind_var(Var),
|
|
goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure,
|
|
GoalInfo),
|
|
Goal = hlds_goal(Unify, GoalInfo),
|
|
Goals = [Goal]
|
|
).
|
|
|
|
:- pred materialize_typeclass_info_var(prog_constraint::in, int::in,
|
|
prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
materialize_typeclass_info_var(Constraint, InstanceIdConstNum, Var, Goals,
|
|
!Info) :-
|
|
poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
|
|
InstanceIdConstArg = csa_const_struct(InstanceIdConstNum),
|
|
( if map.search(ConstStructVarMap0, InstanceIdConstArg, OldVar) then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
Var = OldVar,
|
|
Goals = []
|
|
else
|
|
new_typeclass_info_var(Constraint, typeclass_info_kind, Var, _VarType,
|
|
!Info),
|
|
map.det_insert(InstanceIdConstArg, Var,
|
|
ConstStructVarMap0, ConstStructVarMap),
|
|
poly_info_set_const_struct_var_map(ConstStructVarMap, !Info),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
ConsId = typeclass_info_const(InstanceIdConstNum),
|
|
RHS = rhs_functor(ConsId, is_not_exist_constr, []),
|
|
Unification = construct(Var, ConsId, [], [],
|
|
construct_statically, cell_is_shared, no_construct_sub_info),
|
|
Ground = ground(shared, none_or_default_func),
|
|
UnifyMode = unify_modes_li_lf_ri_rf(free, Ground, Ground, Ground),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
GoalExpr = unify(Var, RHS, UnifyMode, Unification, UnifyContext),
|
|
|
|
% Create a goal_info for the unification.
|
|
NonLocals = set_of_var.make_singleton(Var),
|
|
InstmapDelta = instmap_delta_bind_var(Var),
|
|
goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure,
|
|
GoalInfo),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo),
|
|
Goals = [Goal]
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type const_or_var_arg
|
|
---> cova_const(const_struct_arg)
|
|
; cova_var(prog_var).
|
|
|
|
:- pred make_const_or_var_arg(pair(prog_var, maybe(const_struct_arg))::in,
|
|
const_or_var_arg::out) is det.
|
|
|
|
make_const_or_var_arg(Var - MCA, ConstOrVarArg) :-
|
|
(
|
|
MCA = no,
|
|
ConstOrVarArg = cova_var(Var)
|
|
;
|
|
MCA = yes(ConstArg),
|
|
ConstOrVarArg = cova_const(ConstArg)
|
|
).
|
|
|
|
:- type type_info_var_map ==
|
|
map(type_ctor,
|
|
map(list(mer_type), pair(prog_var, maybe(const_struct_arg)))).
|
|
|
|
:- type typeclass_info_map_entry
|
|
---> typeclass_info_map_entry(
|
|
% The cons_id representing the base_typeclass_info.
|
|
cons_id,
|
|
|
|
% Maps the arguments of the typeclass_info_cell_constructor
|
|
% after the base_typeclass_info to the variable that holds the
|
|
% typeclass_info for that cell.
|
|
map(list(const_or_var_arg),
|
|
pair(prog_var, maybe(const_struct_arg)))
|
|
).
|
|
|
|
:- type typeclass_info_map ==
|
|
map(class_name, map(list(mer_type), typeclass_info_map_entry)).
|
|
|
|
:- type int_const_map == map(int, prog_var).
|
|
|
|
% If the value that can be a constant structure argument is currently
|
|
% available in a variable, give the id of that variable.
|
|
%
|
|
:- type const_struct_var_map == map(const_struct_arg, prog_var).
|
|
|
|
:- type poly_info
|
|
---> poly_info(
|
|
poly_module_info :: module_info,
|
|
|
|
poly_varset :: prog_varset,
|
|
poly_vartypes :: vartypes,
|
|
poly_rtti_varmaps :: rtti_varmaps,
|
|
|
|
poly_typevarset :: tvarset,
|
|
poly_tvar_kind_map :: tvar_kind_map,
|
|
|
|
% Specifies why each constraint that was eliminated from the
|
|
% pred was able to be eliminated (this allows us to efficiently
|
|
% construct the dictionary).
|
|
% Note that the rtti_varmaps is separate from the
|
|
% constraint_proof_map, since the second is the information
|
|
% calculated by typecheck.m, while the first is the information
|
|
% calculated here in polymorphism.m.
|
|
poly_proof_map :: constraint_proof_map,
|
|
|
|
% Specifies the constraints at each location in the goal.
|
|
poly_constraint_map :: constraint_map,
|
|
|
|
% The next four maps hold information about what
|
|
% type_ctor_infos, type_infos, base_typeclass_infos,
|
|
% typeclass_infos and ints are guaranteed to be available
|
|
% (i.e. created by previous code on all execution paths)
|
|
% at the current point in the code, so they can be reused.
|
|
% The fifth field counts the number of times that one of these
|
|
% variables has in fact been reused.
|
|
%
|
|
% The type_infos and typeclass_infos are in the first two maps.
|
|
% The type_ctor_infos and base_typeclass_infos are in the
|
|
% fourth map. The integers are in the third map.
|
|
% The fourth map also caches typeclass_infos for instance ids.
|
|
poly_type_info_var_map :: type_info_var_map,
|
|
poly_typeclass_info_map :: typeclass_info_map,
|
|
poly_int_const_map :: int_const_map,
|
|
poly_const_struct_var_map :: const_struct_var_map,
|
|
poly_num_reuses :: int,
|
|
|
|
poly_snapshot_num :: int,
|
|
|
|
% The database of constant structures of the module.
|
|
% If a type_info or typeclass_info we construct is a constant
|
|
% term, we allocate it in this database.
|
|
poly_const_struct_db :: const_struct_db,
|
|
|
|
% The list of errors we have discovered during the polymorphism
|
|
% pass.
|
|
poly_errors :: list(error_spec)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% Init_poly_info initializes a poly_info from a pred_info and clauses_info.
|
|
% (See also create_poly_info.)
|
|
%
|
|
:- pred init_poly_info(module_info::in, pred_info::in, clauses_info::in,
|
|
poly_info::out) is det.
|
|
|
|
init_poly_info(ModuleInfo, PredInfo, ClausesInfo, PolyInfo) :-
|
|
clauses_info_get_varset(ClausesInfo, VarSet),
|
|
clauses_info_get_vartypes(ClausesInfo, VarTypes),
|
|
pred_info_get_typevarset(PredInfo, TypeVarSet),
|
|
pred_info_get_tvar_kind_map(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proof_map(PredInfo, ProofMap),
|
|
pred_info_get_constraint_map(PredInfo, ConstraintMap),
|
|
rtti_varmaps_init(RttiVarMaps),
|
|
map.init(TypeInfoVarMap),
|
|
map.init(TypeClassInfoMap),
|
|
map.init(IntConstMap),
|
|
map.init(ConstStructVarMap),
|
|
NumReuses = 0,
|
|
SnapshotNum = 0,
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
Specs = [],
|
|
PolyInfo = poly_info(ModuleInfo, VarSet, VarTypes, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, ProofMap, ConstraintMap,
|
|
TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, Specs).
|
|
|
|
create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
|
|
pred_info_get_typevarset(PredInfo, TypeVarSet),
|
|
pred_info_get_tvar_kind_map(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proof_map(PredInfo, ProofMap),
|
|
pred_info_get_constraint_map(PredInfo, ConstraintMap),
|
|
proc_info_get_varset(ProcInfo, VarSet),
|
|
proc_info_get_vartypes(ProcInfo, VarTypes),
|
|
proc_info_get_rtti_varmaps(ProcInfo, RttiVarMaps),
|
|
map.init(TypeInfoVarMap),
|
|
map.init(TypeClassInfoMap),
|
|
map.init(IntConstMap),
|
|
map.init(ConstStructVarMap),
|
|
NumReuses = 0,
|
|
SnapshotNum = 0,
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
Specs = [],
|
|
PolyInfo = poly_info(ModuleInfo, VarSet, VarTypes, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, ProofMap, ConstraintMap,
|
|
TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, Specs).
|
|
|
|
poly_info_extract(Info, Specs, !PredInfo, !ProcInfo, !:ModuleInfo) :-
|
|
Info = poly_info(!:ModuleInfo, VarSet, VarTypes, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, _ProofMap, _ConstraintMap,
|
|
_TypeInfoVarMap, _TypeClassInfoMap, _IntConstMap, _ConstStructVarMap,
|
|
_NumReuses, _SnapshotNum, ConstStructDb, Specs),
|
|
|
|
module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
|
|
|
|
% Set the new values of the fields in proc_info and pred_info.
|
|
proc_info_set_varset(VarSet, !ProcInfo),
|
|
proc_info_set_vartypes(VarTypes, !ProcInfo),
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
|
|
pred_info_set_typevarset(TypeVarSet, !PredInfo),
|
|
pred_info_set_tvar_kind_map(TypeVarKinds, !PredInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred poly_info_get_module_info(poly_info::in,
|
|
module_info::out) is det.
|
|
:- pred poly_info_get_varset(poly_info::in,
|
|
prog_varset::out) is det.
|
|
:- pred poly_info_get_var_types(poly_info::in,
|
|
vartypes::out) is det.
|
|
:- pred poly_info_get_rtti_varmaps(poly_info::in,
|
|
rtti_varmaps::out) is det.
|
|
:- pred poly_info_get_typevarset(poly_info::in,
|
|
tvarset::out) is det.
|
|
:- pred poly_info_get_tvar_kind_map(poly_info::in,
|
|
tvar_kind_map::out) is det.
|
|
:- pred poly_info_get_proof_map(poly_info::in,
|
|
constraint_proof_map::out) is det.
|
|
:- pred poly_info_get_constraint_map(poly_info::in,
|
|
constraint_map::out) is det.
|
|
:- pred poly_info_get_type_info_var_map(poly_info::in,
|
|
type_info_var_map::out) is det.
|
|
:- pred poly_info_get_typeclass_info_map(poly_info::in,
|
|
typeclass_info_map::out) is det.
|
|
:- pred poly_info_get_int_const_map(poly_info::in,
|
|
int_const_map::out) is det.
|
|
:- pred poly_info_get_const_struct_var_map(poly_info::in,
|
|
const_struct_var_map::out) is det.
|
|
:- pred poly_info_get_num_reuses(poly_info::in,
|
|
int::out) is det.
|
|
:- pred poly_info_get_const_struct_db(poly_info::in,
|
|
const_struct_db::out) is det.
|
|
:- pred poly_info_get_errors(poly_info::in,
|
|
list(error_spec)::out) is det.
|
|
|
|
:- pragma inline(poly_info_get_module_info/2).
|
|
:- pragma inline(poly_info_get_varset/2).
|
|
:- pragma inline(poly_info_get_var_types/2).
|
|
:- pragma inline(poly_info_get_rtti_varmaps/2).
|
|
:- pragma inline(poly_info_get_typevarset/2).
|
|
:- pragma inline(poly_info_get_tvar_kind_map/2).
|
|
:- pragma inline(poly_info_get_proof_map/2).
|
|
:- pragma inline(poly_info_get_constraint_map/2).
|
|
:- pragma inline(poly_info_get_type_info_var_map/2).
|
|
:- pragma inline(poly_info_get_typeclass_info_map/2).
|
|
:- pragma inline(poly_info_get_const_struct_var_map/2).
|
|
:- pragma inline(poly_info_get_int_const_map/2).
|
|
:- pragma inline(poly_info_get_num_reuses/2).
|
|
:- pragma inline(poly_info_get_const_struct_db/2).
|
|
:- pragma inline(poly_info_get_errors/2).
|
|
|
|
poly_info_get_module_info(!.PI, X) :-
|
|
X = !.PI ^ poly_module_info.
|
|
poly_info_get_varset(!.PI, X) :-
|
|
X = !.PI ^ poly_varset.
|
|
poly_info_get_var_types(!.PI, X) :-
|
|
X = !.PI ^ poly_vartypes.
|
|
poly_info_get_rtti_varmaps(!.PI, X) :-
|
|
X = !.PI ^ poly_rtti_varmaps.
|
|
poly_info_get_typevarset(!.PI, X) :-
|
|
X = !.PI ^ poly_typevarset.
|
|
poly_info_get_tvar_kind_map(!.PI, X) :-
|
|
X = !.PI ^ poly_tvar_kind_map.
|
|
poly_info_get_proof_map(!.PI, X) :-
|
|
X = !.PI ^ poly_proof_map.
|
|
poly_info_get_constraint_map(!.PI, X) :-
|
|
X = !.PI ^ poly_constraint_map.
|
|
poly_info_get_type_info_var_map(!.PI, X) :-
|
|
X = !.PI ^ poly_type_info_var_map.
|
|
poly_info_get_typeclass_info_map(!.PI, X) :-
|
|
X = !.PI ^ poly_typeclass_info_map.
|
|
poly_info_get_int_const_map(!.PI, X) :-
|
|
X = !.PI ^ poly_int_const_map.
|
|
poly_info_get_const_struct_var_map(!.PI, X) :-
|
|
X = !.PI ^ poly_const_struct_var_map.
|
|
poly_info_get_num_reuses(!.PI, X) :-
|
|
X = !.PI ^ poly_num_reuses.
|
|
poly_info_get_const_struct_db(!.PI, X) :-
|
|
X = !.PI ^ poly_const_struct_db.
|
|
poly_info_get_errors(!.PI, X) :-
|
|
X = !.PI ^ poly_errors.
|
|
|
|
:- pred poly_info_set_varset(prog_varset::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_varset_types(prog_varset::in, vartypes::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_varset_types_rtti(prog_varset::in, vartypes::in,
|
|
rtti_varmaps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_rtti_varmaps(rtti_varmaps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_typevarset(tvarset::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_proof_map(constraint_proof_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_type_info_var_map(type_info_var_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_typeclass_info_map(typeclass_info_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_int_const_map(int_const_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_const_struct_var_map(const_struct_var_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_num_reuses(int::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_const_struct_db(const_struct_db::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_errors(list(error_spec)::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
:- pragma inline(poly_info_set_varset/3).
|
|
:- pragma inline(poly_info_set_varset_types/4).
|
|
:- pragma inline(poly_info_set_varset_types_rtti/5).
|
|
:- pragma inline(poly_info_set_rtti_varmaps/3).
|
|
:- pragma inline(poly_info_set_typevarset/3).
|
|
:- pragma inline(poly_info_set_proof_map/3).
|
|
:- pragma inline(poly_info_set_type_info_var_map/3).
|
|
:- pragma inline(poly_info_set_typeclass_info_map/3).
|
|
:- pragma inline(poly_info_set_int_const_map/3).
|
|
:- pragma inline(poly_info_set_const_struct_var_map/3).
|
|
:- pragma inline(poly_info_set_num_reuses/3).
|
|
:- pragma inline(poly_info_set_const_struct_db/3).
|
|
:- pragma inline(poly_info_set_errors/3).
|
|
|
|
poly_info_set_varset(X, !PI) :-
|
|
!PI ^ poly_varset := X.
|
|
poly_info_set_varset_types(X, Y, !PI) :-
|
|
!:PI = ((!.PI
|
|
^ poly_varset := X)
|
|
^ poly_vartypes := Y).
|
|
poly_info_set_varset_types_rtti(X, Y, Z, !PI) :-
|
|
!:PI = (((!.PI
|
|
^ poly_varset := X)
|
|
^ poly_vartypes := Y)
|
|
^ poly_rtti_varmaps := Z).
|
|
poly_info_set_rtti_varmaps(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_rtti_varmaps) then
|
|
true
|
|
else
|
|
!PI ^ poly_rtti_varmaps := X
|
|
).
|
|
poly_info_set_typevarset(X, !PI) :-
|
|
!PI ^ poly_typevarset := X.
|
|
poly_info_set_proof_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_proof_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_proof_map := X
|
|
).
|
|
poly_info_set_type_info_var_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_type_info_var_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_type_info_var_map := X
|
|
).
|
|
poly_info_set_typeclass_info_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_typeclass_info_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_typeclass_info_map := X
|
|
).
|
|
poly_info_set_int_const_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_int_const_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_int_const_map := X
|
|
).
|
|
poly_info_set_const_struct_var_map(X, !PI) :-
|
|
( if
|
|
private_builtin.pointer_equal(X, !.PI ^ poly_const_struct_var_map)
|
|
then
|
|
true
|
|
else
|
|
!PI ^ poly_const_struct_var_map := X
|
|
).
|
|
poly_info_set_num_reuses(X, !PI) :-
|
|
( if X = !.PI ^ poly_num_reuses then
|
|
true
|
|
else
|
|
!PI ^ poly_num_reuses := X
|
|
).
|
|
poly_info_set_const_struct_db(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_const_struct_db) then
|
|
true
|
|
else
|
|
!PI ^ poly_const_struct_db := X
|
|
).
|
|
poly_info_set_errors(X, !PI) :-
|
|
!PI ^ poly_errors := X.
|
|
|
|
% i read same diff same%
|
|
% 0 6245285 0 1560789 0.000% varset
|
|
% 1 6662703 0 0 vartypes
|
|
% 2 0 1110 129008 0.853% varset, vartypes
|
|
% 17 0 131468 1961967 6.280% varset, vartypes, rtti_varmaps
|
|
% 3 3052707 4 245972 0.002% typevarset
|
|
% 4 1578929 0 0 tvar_kind_map
|
|
% 5 8959328 2116731 988195 68.173% rtti_varmaps
|
|
% 6 14812 3980 4058 49.515% proof_map
|
|
% 7 3030093 0 0 constraint_map
|
|
% 8 811687 776589 288951 72.882% type_info_var_map
|
|
% 9 385071 863384 6104 99.298% typeclass_info_map
|
|
% 10 385706 863310 8464 99.029% int_const_map
|
|
% 11 253310 331092 41528 88.855% num_reuses
|
|
% 12 2559364 25821 15631 62.291% const_struct_db
|
|
% 13 583633 780835 286464 73.160% const_struct_var_map
|
|
% 14 0 0 0 pred_info
|
|
% 15 3933469 0 0 module_info
|
|
% 16 0 431065 87104 83.190% cache_maps_snapshot
|
|
|
|
% :- pragma foreign_decl("C", local,
|
|
% "
|
|
% #define MR_NUM_INFO_STATS 18
|
|
% unsigned long MR_stats_read[MR_NUM_INFO_STATS];
|
|
% unsigned long MR_stats_same[MR_NUM_INFO_STATS];
|
|
% unsigned long MR_stats_diff[MR_NUM_INFO_STATS];
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_read_stats(int::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_read_stats(N::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% ++MR_stats_read[N];
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats(int::in, T::in, T::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats(N::in, Old::in, New::in,
|
|
% PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if (((MR_Unsigned) Old) == ((MR_Unsigned) New)) {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats_2(int::in, T::in, T::in, U::in, U::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats_2(N::in, OldA::in, NewA::in,
|
|
% OldB::in, NewB::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if ((((MR_Unsigned) OldA) == ((MR_Unsigned) NewA)) &&
|
|
% (((MR_Unsigned) OldB) == ((MR_Unsigned) NewB)))
|
|
% {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats_3(int::in, T::in, T::in, U::in, U::in,
|
|
% V::in, V::in, poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats_3(N::in, OldA::in, NewA::in,
|
|
% OldB::in, NewB::in, OldC::in, NewC::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if ((((MR_Unsigned) OldA) == ((MR_Unsigned) NewA)) &&
|
|
% (((MR_Unsigned) OldB) == ((MR_Unsigned) NewB)) &&
|
|
% (((MR_Unsigned) OldC) == ((MR_Unsigned) NewC)))
|
|
% {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- interface.
|
|
% :- import_module io.
|
|
% :- pred write_poly_info_stats(io::di, io::uo) is det.
|
|
% :- implementation.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% write_poly_info_stats(IO0::di, IO::uo),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% FILE *fp;
|
|
%
|
|
% fp = fopen(""/tmp/POLY_INFO_STATS"", ""a"");
|
|
% if (fp != NULL) {
|
|
% int i;
|
|
% for (i = 0; i < MR_NUM_INFO_STATS; i++) {
|
|
% fprintf(fp, ""stat_rsd %d %lu %lu %lu\\n"",
|
|
% i, MR_stats_read[i], MR_stats_same[i], MR_stats_diff[i]);
|
|
% }
|
|
% }
|
|
%
|
|
% IO = IO0;
|
|
% ").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type cache_maps
|
|
---> cache_maps(
|
|
cm_snapshot_num :: int,
|
|
cm_type_info_var_map :: type_info_var_map,
|
|
cm_typeclass_info_map :: typeclass_info_map,
|
|
cm_int_const_map :: int_const_map,
|
|
cm_const_struct_var_map :: const_struct_var_map
|
|
).
|
|
|
|
:- pred get_cache_maps_snapshot(string::in, cache_maps::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
get_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap),
|
|
poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap),
|
|
poly_info_get_int_const_map(!.Info, IntConstMap),
|
|
poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap),
|
|
|
|
SnapshotNum = !.Info ^ poly_snapshot_num,
|
|
CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
|
|
IntConstMap, ConstStructVarMap),
|
|
!Info ^ poly_snapshot_num := SnapshotNum + 1,
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
( if
|
|
SelectedPred = yes,
|
|
Name \= ""
|
|
then
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.format("get_cache_maps_snapshot %d %s\n",
|
|
[i(SnapshotNum), s(Name)], !IO),
|
|
io.write_string(IndentStr, !IO),
|
|
poly_info_get_varset(!.Info, VarSet),
|
|
NumVars = varset.num_allocated(VarSet),
|
|
io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO)
|
|
else
|
|
true
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
:- pred set_cache_maps_snapshot(string::in, cache_maps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
set_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
|
|
IntConstMap, ConstStructVarMap),
|
|
( if
|
|
private_builtin.pointer_equal(TypeInfoVarMap,
|
|
!.Info ^ poly_type_info_var_map),
|
|
private_builtin.pointer_equal(TypeClassInfoMap,
|
|
!.Info ^ poly_typeclass_info_map),
|
|
private_builtin.pointer_equal(IntConstMap,
|
|
!.Info ^ poly_int_const_map),
|
|
private_builtin.pointer_equal(ConstStructVarMap,
|
|
!.Info ^ poly_const_struct_var_map)
|
|
then
|
|
true
|
|
else
|
|
!:Info = ((((!.Info
|
|
^ poly_type_info_var_map := TypeInfoVarMap)
|
|
^ poly_typeclass_info_map := TypeClassInfoMap)
|
|
^ poly_int_const_map := IntConstMap)
|
|
^ poly_const_struct_var_map := ConstStructVarMap)
|
|
),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
( if
|
|
SelectedPred = yes,
|
|
Name \= ""
|
|
then
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.format("set_cache_maps_snapshot %d %s\n",
|
|
[i(SnapshotNum), s(Name)], !IO),
|
|
io.write_string(IndentStr, !IO),
|
|
poly_info_get_varset(!.Info, VarSet),
|
|
NumVars = varset.num_allocated(VarSet),
|
|
io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("type_info_var_map ", !IO),
|
|
io.write(CacheMaps ^ cm_type_info_var_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("typeclass_info_map ", !IO),
|
|
io.write(CacheMaps ^ cm_typeclass_info_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("struct_var_map ", !IO),
|
|
io.write(CacheMaps ^ cm_const_struct_var_map, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
else
|
|
true
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
:- pred empty_cache_maps(poly_info::in, poly_info::out) is det.
|
|
|
|
empty_cache_maps(!Info) :-
|
|
poly_info_set_type_info_var_map(map.init, !Info),
|
|
poly_info_set_typeclass_info_map(map.init, !Info),
|
|
poly_info_set_int_const_map(map.init, !Info),
|
|
poly_info_set_const_struct_var_map(map.init, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type var_maps
|
|
---> var_maps(
|
|
vm_snapshot_num :: int,
|
|
vm_varset :: prog_varset,
|
|
vm_vartypes :: vartypes,
|
|
vm_rtti_varmaps :: rtti_varmaps,
|
|
vm_cache_maps :: cache_maps
|
|
).
|
|
|
|
:- pred get_var_maps_snapshot(string::in, var_maps::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
get_var_maps_snapshot(Name, VarMaps, !Info) :-
|
|
SnapshotNum = !.Info ^ poly_snapshot_num,
|
|
poly_info_get_varset(!.Info, VarSet),
|
|
poly_info_get_var_types(!.Info, VarTypes),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
NumVars = varset.num_allocated(VarSet),
|
|
io.format("%sget_var_maps_snapshot %d %s\n",
|
|
[s(IndentStr), i(SnapshotNum), s(Name)], !IO),
|
|
io.format("%snum_allocated vars: %d\n\n",
|
|
[s(IndentStr), i(NumVars)], !IO)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
|
|
get_cache_maps_snapshot("", CacheMaps, !Info),
|
|
VarMaps = var_maps(SnapshotNum, VarSet, VarTypes, RttiVarMaps, CacheMaps).
|
|
|
|
:- pred set_var_maps_snapshot(string::in, var_maps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
set_var_maps_snapshot(Name, VarMaps, !Info) :-
|
|
VarMaps = var_maps(SnapshotNum, VarSet, VarTypes, RttiVarMaps, CacheMaps),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
some [SelectedPred, Level, IndentStr] (
|
|
promise_pure (
|
|
semipure get_selected_pred(SelectedPred),
|
|
semipure get_level(Level),
|
|
(
|
|
SelectedPred = no
|
|
;
|
|
SelectedPred = yes,
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
io.write_string(IndentStr, !IO),
|
|
io.format("set_var_maps_snapshot %d %s\n",
|
|
[i(SnapshotNum), s(Name)], !IO),
|
|
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("type_info_var_map ", !IO),
|
|
io.write(CacheMaps ^ cm_type_info_var_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("typeclass_info_map ", !IO),
|
|
io.write(CacheMaps ^ cm_typeclass_info_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("struct_var_map ", !IO),
|
|
io.write(CacheMaps ^ cm_const_struct_var_map, !IO),
|
|
io.nl(!IO),
|
|
io.nl(!IO)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
|
|
poly_info_set_varset_types_rtti(VarSet, VarTypes, RttiVarMaps, !Info),
|
|
set_cache_maps_snapshot("", CacheMaps, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.polymorphism.
|
|
%---------------------------------------------------------------------------%
|