mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 09:40:21 +00:00
42194094a2
lib/linguist/languages.yml:
Add the declaration for the language.
samples/Mercury:
Add samples for the classifier as Mercury shares it's filename extension
with several other languages.
4638 lines
200 KiB
Mathematica
4638 lines
200 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1995-2012 The University of Melbourne.
|
|
% 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 mdbcomp.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.
|
|
:- 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) 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.
|
|
%
|
|
:- 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.
|
|
%
|
|
:- 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.
|
|
|
|
% 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.
|
|
|
|
% 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, Goals, TypeInfoVar, ...):
|
|
%
|
|
% 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.
|
|
% Index 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.
|
|
%
|
|
:- pred gen_extract_type_info(module_info::in, tvar::in, kind::in,
|
|
prog_var::in, int_or_var::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, 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.
|
|
|
|
% Look up the pred_id and proc_id for a type specific
|
|
% unification/comparison/index/initialise predicate.
|
|
%
|
|
:- pred get_special_proc(mer_type::in, special_pred_id::in,
|
|
module_info::in, sym_name::out, pred_id::out, proc_id::out) is semidet.
|
|
:- pred get_special_proc_det(mer_type::in, special_pred_id::in,
|
|
module_info::in, sym_name::out, pred_id::out, proc_id::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, unify_rhs::out, prog_varset::in, prog_varset::out,
|
|
vartypes::in, vartypes::out) is det.
|
|
|
|
% fix_undetermined_mode_lambda_goal(ProcId, Functor0, Functor, ModuleInfo)
|
|
%
|
|
% 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(proc_id::in,
|
|
unify_rhs::in(rhs_lambda_goal), unify_rhs::out(rhs_lambda_goal),
|
|
module_info::in) 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.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.clause_to_proc.
|
|
:- import_module check_hlds.mode_util.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.from_ground_term_util.
|
|
:- import_module hlds.const_struct.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_args.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_code_util.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.instmap.
|
|
:- import_module hlds.passes_aux.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.quantification.
|
|
:- import_module hlds.special_pred.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.goal_path.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.program_representation.
|
|
:- import_module parse_tree.builtin_lib_types.
|
|
:- import_module parse_tree.prog_mode.
|
|
:- 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 term.
|
|
:- 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've finished the first pass.
|
|
|
|
polymorphism_process_module(!ModuleInfo) :-
|
|
module_info_get_preds(!.ModuleInfo, Preds0),
|
|
map.keys(Preds0, PredIds0),
|
|
list.foldl(maybe_polymorphism_process_pred, PredIds0, !ModuleInfo),
|
|
module_info_get_preds(!.ModuleInfo, Preds1),
|
|
map.keys(Preds1, PredIds1),
|
|
list.foldl(fixup_pred_polymorphism, PredIds1, !ModuleInfo),
|
|
expand_class_method_bodies(!ModuleInfo).
|
|
|
|
:- pred maybe_polymorphism_process_pred(pred_id::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
maybe_polymorphism_process_pred(PredId, !ModuleInfo) :-
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
|
|
(
|
|
PredModule = pred_info_module(PredInfo),
|
|
PredName = pred_info_name(PredInfo),
|
|
PredArity = pred_info_orig_arity(PredInfo),
|
|
no_type_info_builtin(PredModule, PredName, PredArity)
|
|
->
|
|
% Just copy the clauses to the proc_infos.
|
|
copy_module_clauses_to_procs([PredId], !ModuleInfo)
|
|
;
|
|
polymorphism_process_pred_msg(PredId, !ModuleInfo)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred fixup_pred_polymorphism(pred_id::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
fixup_pred_polymorphism(PredId, !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.
|
|
|
|
(
|
|
ExistQVars = [_ | _],
|
|
% This can fail for unification procedures of equivalence types.
|
|
lookup_var_types(VarTypes0, OldHeadVarList, OldHeadVarTypes),
|
|
type_list_subsumes(ArgTypes0, OldHeadVarTypes, Subn),
|
|
\+ map.is_empty(Subn)
|
|
->
|
|
pred_info_set_existq_tvar_binding(Subn, PredInfo1, PredInfo2),
|
|
polymorphism_introduce_exists_casts_pred(!.ModuleInfo, PredInfo2,
|
|
PredInfo)
|
|
;
|
|
PredInfo = PredInfo1
|
|
),
|
|
|
|
map.det_update(PredId, PredInfo, PredTable0, PredTable),
|
|
module_info_set_preds(PredTable, !ModuleInfo).
|
|
|
|
:- pred polymorphism_introduce_exists_casts_pred(module_info::in,
|
|
pred_info::in, pred_info::out) is det.
|
|
|
|
polymorphism_introduce_exists_casts_pred(ModuleInfo, !PredInfo) :-
|
|
pred_info_get_procedures(!.PredInfo, Procs0),
|
|
map.map_values_only(
|
|
(pred(!.ProcInfo::in, !:ProcInfo::out) is det :-
|
|
% Add the extra goals to each procedure.
|
|
introduce_exists_casts_proc(ModuleInfo, !.PredInfo, !ProcInfo)
|
|
), Procs0, Procs),
|
|
pred_info_set_procedures(Procs, !PredInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred polymorphism_process_pred_msg(pred_id::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
polymorphism_process_pred_msg(PredId, !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, !ModuleInfo).
|
|
|
|
polymorphism_process_generated_pred(PredId, !ModuleInfo) :-
|
|
polymorphism_process_pred(PredId, !ModuleInfo),
|
|
fixup_pred_polymorphism(PredId, !ModuleInfo).
|
|
|
|
:- mutable(selected_pred, bool, no, ground, [untrailed]).
|
|
:- mutable(level, int, 0, ground, [untrailed]).
|
|
|
|
:- pred polymorphism_process_pred(pred_id::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
polymorphism_process_pred(PredId, !ModuleInfo) :-
|
|
trace [compiletime(flag("debug_poly_caches"))] (
|
|
promise_pure (
|
|
% Replace 99999 with the id of the predicate you want to debug.
|
|
( pred_id_to_int(PredId) = 15 ->
|
|
impure set_selected_pred(yes)
|
|
;
|
|
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, Info, ExtraArgModes),
|
|
poly_info_get_module_info(Info, !:ModuleInfo),
|
|
poly_info_get_const_struct_db(Info, ConstStructDb),
|
|
module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
|
|
|
|
poly_info_get_typevarset(Info, TypeVarSet),
|
|
pred_info_set_typevarset(TypeVarSet, PredInfo0, PredInfo1),
|
|
pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
|
|
|
|
% Do a pass over the proc_infos, copying the relevant information
|
|
% from the clauses_info and the poly_info, and updating all the argmodes
|
|
% with modes for the extra arguments.
|
|
|
|
ProcIds = pred_info_procids(PredInfo2),
|
|
pred_info_get_procedures(PredInfo2, Procs0),
|
|
list.foldl(polymorphism_process_proc_in_table(PredInfo2, ClausesInfo,
|
|
ExtraArgModes), ProcIds, Procs0, Procs),
|
|
pred_info_set_procedures(Procs, 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),
|
|
|
|
setup_headvars(PredInfo0, HeadVars0, HeadVars,
|
|
ExtraArgModes, UnconstrainedTVars,
|
|
ExtraTypeInfoHeadVars, ExistTypeClassInfoHeadVars, !Info),
|
|
|
|
get_clause_list(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),
|
|
map.init(TVarNameMap), % This is only used while adding the clauses.
|
|
!:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
|
|
VarTypes, HeadVars, ClausesRep, ItemNumbers,
|
|
RttiVarMaps, HaveForeignClauses).
|
|
|
|
:- 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) :-
|
|
( pred_info_is_imported(PredInfo0) ->
|
|
true
|
|
;
|
|
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 polymorphism_process_proc_in_table(pred_info::in, clauses_info::in,
|
|
poly_arg_vector(mer_mode)::in, proc_id::in,
|
|
proc_table::in, proc_table::out) is det.
|
|
|
|
polymorphism_process_proc_in_table(PredInfo, ClausesInfo, ExtraArgModes,
|
|
ProcId, !ProcTable) :-
|
|
map.lookup(!.ProcTable, ProcId, ProcInfo0),
|
|
polymorphism_process_proc(PredInfo, ClausesInfo, ExtraArgModes, ProcId,
|
|
ProcInfo0, ProcInfo),
|
|
map.det_update(ProcId, ProcInfo, !ProcTable).
|
|
|
|
:- pred polymorphism_process_proc(pred_info::in, clauses_info::in,
|
|
poly_arg_vector(mer_mode)::in, proc_id::in, proc_info::in, proc_info::out)
|
|
is det.
|
|
|
|
polymorphism_process_proc(PredInfo, ClausesInfo, ExtraArgModes, ProcId,
|
|
!ProcInfo) :-
|
|
% Copy all the information from the clauses_info into the proc_info.
|
|
(
|
|
(
|
|
pred_info_is_imported(PredInfo)
|
|
;
|
|
pred_info_is_pseudo_imported(PredInfo),
|
|
hlds_pred.in_in_unification_proc_id(ProcId)
|
|
)
|
|
->
|
|
% We need to set these fields in the proc_info here, because some parts
|
|
% of the compiler (e.g. unused_args.m) depend on these fields being
|
|
% valid even for imported procedures.
|
|
|
|
% XXX ARGVEC - when the proc_info uses the proc_arg_vector just
|
|
% pass the headvar vector directly to the proc_info.
|
|
clauses_info_get_headvars(ClausesInfo, HeadVars),
|
|
HeadVarList = proc_arg_vector_to_list(HeadVars),
|
|
clauses_info_get_rtti_varmaps(ClausesInfo, RttiVarMaps),
|
|
clauses_info_get_varset(ClausesInfo, VarSet),
|
|
clauses_info_get_vartypes(ClausesInfo, VarTypes),
|
|
proc_info_set_headvars(HeadVarList, !ProcInfo),
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
|
|
proc_info_set_varset(VarSet, !ProcInfo),
|
|
proc_info_set_vartypes(VarTypes, !ProcInfo)
|
|
;
|
|
copy_clauses_to_proc(ProcId, ClausesInfo, !ProcInfo)
|
|
),
|
|
|
|
% 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).
|
|
|
|
% 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_transformed(_, _, _)
|
|
; Origin = origin_created(_)
|
|
; Origin = origin_assertion(_, _)
|
|
; Origin = origin_lambda(_, _, _)
|
|
; 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),
|
|
(
|
|
pred_info_get_markers(PredInfo, PredMarkers),
|
|
check_marker(PredMarkers, marker_class_method)
|
|
->
|
|
% 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
|
|
;
|
|
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_kinds(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.
|
|
|
|
( vartypes_is_empty(VarTypes0) ->
|
|
% This can happen for compiler generated procedures.
|
|
map.init(PredToActualTypeSubst)
|
|
;
|
|
HeadVarList = proc_arg_vector_to_list(HeadVars),
|
|
lookup_var_types(VarTypes0, HeadVarList, ActualArgTypes),
|
|
type_list_subsumes(ArgTypes, ActualArgTypes, ArgTypeSubst)
|
|
->
|
|
PredToActualTypeSubst = ArgTypeSubst
|
|
;
|
|
% 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($module, $pred, "length mismatch").
|
|
assign_var_list([_ | _], [], _) :-
|
|
unexpected($module, $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) :-
|
|
( Var1 = Var2 ->
|
|
Goal = true_goal
|
|
;
|
|
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),
|
|
(
|
|
search_hlds_constraint_list(ConstraintMap, unproven, goal_id(0),
|
|
NumExistConstraints, ActualExistConstraints0)
|
|
->
|
|
ActualExistConstraints = ActualExistConstraints0
|
|
;
|
|
% 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),
|
|
|
|
( no_type_info_builtin(PredModule, PredName, PredArity) ->
|
|
Goal = Goal0
|
|
;
|
|
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 = promise_purity(_)
|
|
; Reason0 = require_detism(_)
|
|
; Reason0 = require_complete_switch(_)
|
|
; 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),
|
|
(
|
|
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo),
|
|
SubGoalExpr0 = conj(plain_conj, Conjuncts0),
|
|
Conjuncts0 = [ConjunctA0, ConjunctB0]
|
|
->
|
|
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)
|
|
;
|
|
unexpected($module, $pred, "malformed try goal")
|
|
),
|
|
set_cache_maps_snapshot("after try", InitialSnapshot, !Info),
|
|
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
|
|
;
|
|
ShortHand0 = bi_implication(_, _),
|
|
unexpected($module, $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),
|
|
( SubGoalExpr0 = conj(plain_conj, SubGoals0Prime) ->
|
|
SubGoals0 = SubGoals0Prime
|
|
;
|
|
unexpected($module, $pred,
|
|
"from_ground_term_initial goal is not plain conj")
|
|
),
|
|
polymorphism_process_fgti_goals(SubGoals0, [], RevMarkedSubGoals,
|
|
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,
|
|
RevMarkedSubGoals, 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([], !RevMarkedGoals, !InvariantsStatus, !Info).
|
|
polymorphism_process_fgti_goals([Goal0 | Goals0], !RevMarkedGoals,
|
|
!InvariantsStatus, !Info) :-
|
|
% This is used only if polymorphism_fgt_sanity_tests is enabled.
|
|
OldInfo = !.Info,
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
|
|
(
|
|
GoalExpr0 = unify(XVarPrime, Y, ModePrime, UnificationPrime,
|
|
UnifyContextPrime),
|
|
Y = rhs_functor(ConsIdPrime, _, YVarsPrime)
|
|
->
|
|
XVar = XVarPrime,
|
|
Mode = ModePrime,
|
|
Unification = UnificationPrime,
|
|
UnifyContext = UnifyContextPrime,
|
|
ConsId = ConsIdPrime,
|
|
YVars = YVarsPrime
|
|
;
|
|
unexpected($module, $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), $module, $pred,
|
|
"MaxVarBefore != MaxVarAfter"),
|
|
expect(unify(NumReusesBefore, NumReusesAfter), $module, $pred,
|
|
"NumReusesBefore != NumReusesAfter"),
|
|
expect(unify(Goal0, Goal), $module, $pred,
|
|
"Goal0 != Goal")
|
|
),
|
|
MarkedGoal = fgt_kept_goal(Goal0, XVar, YVars)
|
|
;
|
|
Changed = yes,
|
|
MarkedGoal = fgt_broken_goal(Goal, XVar, YVars),
|
|
!:InvariantsStatus = fgt_invariants_broken
|
|
),
|
|
!:RevMarkedGoals = [MarkedGoal | !.RevMarkedGoals],
|
|
polymorphism_process_fgti_goals(Goals0, !RevMarkedGoals,
|
|
!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.
|
|
|
|
(
|
|
% 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)
|
|
->
|
|
% 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.
|
|
( ProcId0 = invalid_proc_id ->
|
|
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($module, $pred, "no modes")
|
|
)
|
|
;
|
|
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, Functor0, VarSet0, VarSet, VarTypes0, VarTypes),
|
|
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
|
|
% Process the unification in its new form.
|
|
polymorphism_process_unify(X0, Functor0, Mode0, Unification0,
|
|
UnifyContext, GoalInfo1, Goal, !Info),
|
|
Changed = yes
|
|
;
|
|
% 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),
|
|
( remove_new_prefix(Functor0, OrigFunctor) ->
|
|
ConsId = cons(OrigFunctor, Arity, ConsTypeCtor),
|
|
IsConstruction = yes
|
|
;
|
|
ConsId = ConsId0,
|
|
IsConstruction = no
|
|
),
|
|
|
|
% Check whether the functor (with the "new " prefix removed)
|
|
% is an existentially typed functor.
|
|
type_util.get_existq_cons_defn(ModuleInfo0, TypeOfX, ConsId, ConsDefn)
|
|
->
|
|
% 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,
|
|
IsConstruction, 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, IsConstruction, ArgVars),
|
|
Mode0, Unification, UnifyContext),
|
|
Unify = hlds_goal(UnifyExpr, GoalInfo),
|
|
GoalList = ExtraGoals ++ [Unify],
|
|
conj_list_to_goal(GoalList, GoalInfo0, Goal),
|
|
Changed = yes
|
|
;
|
|
% 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),
|
|
GoalExpr = unify(X0, rhs_functor(ConsId0, no, ArgVars0), Mode0,
|
|
Unification, UnifyContext),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo)
|
|
).
|
|
|
|
convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
|
|
ArgVars0, PredArgTypes, UnifyContext, GoalInfo0, Context,
|
|
ModuleInfo0, Functor, !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),
|
|
RHS = rhs_functor(ConsId, no, ArgVars0),
|
|
CallUnifyContext = call_unify_context(X0, RHS, 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),
|
|
goal_info_init(LambdaGoalInfo0),
|
|
goal_info_set_context(Context, LambdaGoalInfo0, LambdaGoalInfo1),
|
|
goal_info_set_nonlocals(LambdaNonLocals, LambdaGoalInfo1, LambdaGoalInfo2),
|
|
goal_info_set_purity(Purity, LambdaGoalInfo2, LambdaGoalInfo3),
|
|
goal_info_set_goal_id(GoalId, LambdaGoalInfo3, 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(ProcInfo, LambdaVars, LambdaModes, LambdaDet),
|
|
|
|
% Construct the lambda expression.
|
|
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
% Higher-order values created in this fashion are always ground.
|
|
Groundness = ho_ground,
|
|
Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
|
|
|
|
fix_undetermined_mode_lambda_goal(ProcId, Functor0, Functor, ModuleInfo) :-
|
|
Functor0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, _LambdaModes0, _LambdaDet0, LambdaGoal0),
|
|
LambdaGoal0 = hlds_goal(_, LambdaGoalInfo),
|
|
goal_to_conj_list(LambdaGoal0, LambdaGoalList0),
|
|
(
|
|
list.split_last(LambdaGoalList0, LambdaGoalButLast0, LastGoal0),
|
|
LastGoal0 = hlds_goal(LastGoalExpr0, LastGoalInfo0),
|
|
LastGoalExpr0 = plain_call(PredId0, _DummyProcId, Args0, not_builtin,
|
|
MaybeCallUnifyContext0, QualifiedPName0)
|
|
->
|
|
LambdaGoalButLast = LambdaGoalButLast0,
|
|
LastGoalInfo = LastGoalInfo0,
|
|
PredId = PredId0,
|
|
Args = Args0,
|
|
MaybeCallUnifyContext = MaybeCallUnifyContext0,
|
|
QualifiedPName = QualifiedPName0
|
|
;
|
|
unexpected($module, $pred, "unmatched lambda goal")
|
|
),
|
|
|
|
module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo),
|
|
|
|
% Build up the lambda goal.
|
|
LastGoalExpr = plain_call(PredId, ProcId, Args, not_builtin,
|
|
MaybeCallUnifyContext, QualifiedPName),
|
|
LastGoal = hlds_goal(LastGoalExpr, LastGoalInfo),
|
|
conj_list_to_goal(LambdaGoalButLast ++ [LastGoal], LambdaGoalInfo,
|
|
LambdaGoal),
|
|
|
|
% Work out the modes of the introduced lambda variables and the determinism
|
|
% of the lambda goal.
|
|
lambda_modes_and_det(ProcInfo, LambdaVars, LambdaModes, LambdaDet),
|
|
|
|
% Construct the lambda expression.
|
|
Functor = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
|
|
ArgVars0, LambdaVars, LambdaModes, LambdaDet, LambdaGoal).
|
|
|
|
:- pred lambda_modes_and_det(proc_info::in, prog_vars::in, list(mer_mode)::out,
|
|
determinism::out) is det.
|
|
|
|
lambda_modes_and_det(ProcInfo, LambdaVars, LambdaModes, LambdaDet) :-
|
|
proc_info_get_argmodes(ProcInfo, ArgModes),
|
|
list.length(ArgModes, NumArgModes),
|
|
list.length(LambdaVars, NumLambdaVars),
|
|
( list.drop(NumArgModes - NumLambdaVars, ArgModes, LambdaModesPrime) ->
|
|
LambdaModes = LambdaModesPrime
|
|
;
|
|
unexpected($module, $pred, "list.drop failed")
|
|
),
|
|
proc_info_get_declared_determinism(ProcInfo, MaybeDet),
|
|
(
|
|
MaybeDet = yes(Det),
|
|
LambdaDet = Det
|
|
;
|
|
MaybeDet = no,
|
|
sorry($module, $pred,
|
|
"determinism inference for higher order predicate terms.")
|
|
).
|
|
|
|
:- 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, bool::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, IsConstruction,
|
|
ActualArgTypes, ActualRetType, GoalInfo,
|
|
ExtraVars, ExtraGoals, !Info) :-
|
|
CtorDefn = ctor_defn(CtorTypeVarSet, CtorExistQVars, CtorKindMap,
|
|
CtorExistentialConstraints, CtorArgTypes, CtorRetType),
|
|
|
|
% Rename apart the type variables in the constructor definition.
|
|
poly_info_get_typevarset(!.Info, TypeVarSet0),
|
|
tvarset_merge_renaming(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
|
|
CtorToParentRenaming),
|
|
apply_variable_renaming_to_tvar_list(CtorToParentRenaming,
|
|
CtorExistQVars, ParentExistQVars),
|
|
apply_variable_renaming_to_tvar_kind_map(CtorToParentRenaming,
|
|
CtorKindMap, ParentKindMap),
|
|
apply_variable_renaming_to_prog_constraint_list(CtorToParentRenaming,
|
|
CtorExistentialConstraints, ParentExistentialConstraints),
|
|
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),
|
|
list.length(ParentExistentialConstraints, NumExistentialConstraints),
|
|
Context = goal_info_get_context(GoalInfo),
|
|
(
|
|
IsConstruction = yes,
|
|
% 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)
|
|
;
|
|
IsConstruction = no,
|
|
% Assume it is a deconstruction.
|
|
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
|
|
NumExistentialConstraints, ActualExistentialConstraints),
|
|
make_existq_typeclass_info_vars(ActualExistentialConstraints,
|
|
ExtraTypeClassVars, ExtraTypeClassGoals, !Info)
|
|
),
|
|
|
|
% 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),
|
|
|
|
% 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_code_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_code_impl::in, tvarset::in, prog_constraint::in,
|
|
pair(maybe(pair(string, mer_mode)), box_policy)::out) is det.
|
|
|
|
foreign_proc_add_typeclass_info(CanOptAwayUnnamed, Mode, Impl, TypeVarSet,
|
|
Constraint, MaybeArgName - native_if_possible) :-
|
|
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.
|
|
(
|
|
CanOptAwayUnnamed = yes,
|
|
foreign_code_does_not_use_variable(Impl, ConstraintVarName)
|
|
->
|
|
MaybeArgName = no
|
|
;
|
|
MaybeArgName = yes(ConstraintVarName - Mode)
|
|
).
|
|
|
|
:- pred foreign_proc_add_typeinfo(bool::in, mer_mode::in,
|
|
pragma_foreign_code_impl::in, tvarset::in, tvar::in,
|
|
pair(maybe(pair(string, mer_mode)), box_policy)::out) is det.
|
|
|
|
foreign_proc_add_typeinfo(CanOptAwayUnnamed, Mode, Impl, TypeVarSet, TVar,
|
|
MaybeArgName - native_if_possible) :-
|
|
( varset.search_name(TypeVarSet, TVar, TypeVarName) ->
|
|
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.
|
|
(
|
|
CanOptAwayUnnamed = yes,
|
|
foreign_code_does_not_use_variable(Impl, C_VarName)
|
|
->
|
|
MaybeArgName = no
|
|
;
|
|
MaybeArgName = yes(C_VarName - Mode)
|
|
)
|
|
;
|
|
MaybeArgName = no
|
|
).
|
|
|
|
:- pred foreign_code_does_not_use_variable(pragma_foreign_code_impl::in,
|
|
string::in) is semidet.
|
|
|
|
foreign_code_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.
|
|
% semidet_fail,
|
|
\+ foreign_code_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_kinds(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.
|
|
|
|
( varset.is_empty(PredTypeVarSet) ->
|
|
% Optimize a common case.
|
|
map.init(PredToParentTypeRenaming),
|
|
TypeVarSet = TypeVarSet0,
|
|
ParentArgTypes = PredArgTypes,
|
|
ParentKindMap = PredKindMap,
|
|
ParentTVars = [],
|
|
ParentExistQVars = []
|
|
;
|
|
% 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),
|
|
(
|
|
(
|
|
% 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)
|
|
)
|
|
->
|
|
GoalInfo = GoalInfo0,
|
|
ExtraGoals = [],
|
|
ExtraVars = []
|
|
;
|
|
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),
|
|
(
|
|
prog_type.type_list_to_var_list(ActualExistQVarTypes,
|
|
ActualExistQVars0)
|
|
->
|
|
ActualExistQVars = ActualExistQVars0
|
|
;
|
|
unexpected($module, $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,
|
|
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)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
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,
|
|
(
|
|
list.drop(NExtraArgs, PredArgTypes, OrigPredArgTypes0),
|
|
list.take(NExtraArgs, CalleeHeadVars, CalleeExtraHeadVars0)
|
|
->
|
|
OrigPredArgTypes = OrigPredArgTypes0,
|
|
CalleeExtraHeadVars = CalleeExtraHeadVars0
|
|
;
|
|
unexpected($module, $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($module, $pred,
|
|
"unsupported: constraints on initialisation preds")
|
|
;
|
|
VarInfo = non_rtti_var,
|
|
unexpected($module, $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) :-
|
|
(
|
|
% Optimize common case.
|
|
ExistQVars = [],
|
|
rtti_varmaps_no_tvars(!.Info ^ poly_rtti_varmaps),
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
NumReuses = 0
|
|
->
|
|
Goal = Goal0
|
|
;
|
|
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_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(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),
|
|
( rtti_varmaps_no_tvars(RttiVarMaps0) ->
|
|
set_of_var.init(NewOutsideVars)
|
|
;
|
|
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_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(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) :-
|
|
(
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
|
|
OldTypeClassInfoVar)
|
|
->
|
|
% 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 = []
|
|
;
|
|
% We don't have the typeclass_info, so we must either have a proof
|
|
% that tells us how to make it, or ...
|
|
map.search(!.Info ^ poly_proof_map, Constraint, Proof)
|
|
->
|
|
make_typeclass_info_from_proof(Constraint, Seen, Proof, ExistQVars,
|
|
Context, TypeClassInfoVarMCA, Goals, !Info)
|
|
;
|
|
% ... 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),
|
|
( Seen = [Constraint] ->
|
|
io.write_string("[Constraint]\n", !IO)
|
|
;
|
|
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 ^ class_vars, SubClassTypes,
|
|
SubTypeSubst),
|
|
apply_subst_to_prog_constraint_list(SubTypeSubst,
|
|
SubClassDefn ^ class_supers, SuperClasses),
|
|
( list.nth_member_search(SuperClasses, Constraint, SuperClassIndex0) ->
|
|
SuperClassIndex0 = SuperClassIndex
|
|
;
|
|
% We shouldn't have got this far if the constraints were not satisfied.
|
|
unexpected($module, $pred, "constraint not in constraint list")
|
|
),
|
|
|
|
(
|
|
SubClassMCA = yes(SubClassConstArg),
|
|
(
|
|
SubClassConstArg = csa_constant(_, _),
|
|
unexpected($module, $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,
|
|
_, _),
|
|
(
|
|
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)
|
|
->
|
|
materialize_typeclass_info_var(Constraint, SelectedConstNum,
|
|
TypeClassInfoVar, Goals, !Info),
|
|
MaybeTCIConstArg = yes(SelectedArg)
|
|
;
|
|
unexpected($module, $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(mercury_private_builtin_module,
|
|
"superclass_from_typeclass_info",
|
|
pf_predicate, only_mode, detism_det, purity_pure,
|
|
[SubClassVar, IndexVar, TypeClassInfoVar], [],
|
|
instmap_delta_bind_no_var, ModuleInfo, 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),
|
|
( Seen = [Constraint] ->
|
|
io.write_string("[Constraint]\n", !IO)
|
|
;
|
|
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),
|
|
(
|
|
ExistQVars = [],
|
|
search_for_constant_instance(ConstStructDb0, InstanceId,
|
|
InstanceIdConstNum)
|
|
->
|
|
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)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
;
|
|
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),
|
|
io.write(!.Info ^ poly_type_info_var_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("typeclass_info_map ", !IO),
|
|
io.write(!.Info ^ poly_typeclass_info_map, !IO),
|
|
io.nl(!IO),
|
|
io.write_string(IndentStr, !IO),
|
|
io.write_string("struct_var_map ", !IO),
|
|
io.write(!.Info ^ poly_const_struct_var_map, !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_proofs(!.Info, Proofs0),
|
|
|
|
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(_, _, _, InstanceConstraints,
|
|
InstanceTypes, _, _, _, InstanceTVarset, InstanceProofs),
|
|
|
|
% 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_proofs(Renaming,
|
|
InstanceProofs, RenamedInstanceProofs),
|
|
apply_rec_subst_to_constraint_proofs(InstanceSubst,
|
|
RenamedInstanceProofs, ActualInstanceProofs),
|
|
|
|
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(Proofs0, ActualInstanceProofs, Proofs),
|
|
|
|
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, Proofs,
|
|
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),
|
|
(
|
|
map.search(TypeClassInfoMap0, ConstraintClassName, ClassNameMap0),
|
|
map.search(ClassNameMap0, ConstraintArgTypes, OldEntry0),
|
|
OldEntry0 = typeclass_info_map_entry(_BaseConsId, ArgsMap0),
|
|
map.search(ArgsMap0, ArgCOVAs, OldTypeClassInfoVarMCA0)
|
|
->
|
|
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)
|
|
;
|
|
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),
|
|
( map.search(TypeClassInfoMap1, ConstraintClassName, ClassNameMap1) ->
|
|
( map.search(ClassNameMap1, ConstraintArgTypes, OldEntry1) ->
|
|
OldEntry1 = typeclass_info_map_entry(BaseConsId1, ArgsMap1),
|
|
expect(unify(BaseConsId1, BaseConsId), $module, $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)
|
|
;
|
|
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)
|
|
)
|
|
;
|
|
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)
|
|
),
|
|
|
|
(
|
|
TypeClassInfoVarMCA = _ - yes(TypeClassInfoConstArg),
|
|
TypeClassInfoConstArg = csa_const_struct(TypeClassInfoConstArgNum)
|
|
->
|
|
poly_info_get_const_struct_db(!.Info, ConstStructDb1),
|
|
insert_constant_instance(InstanceId, TypeClassInfoConstArgNum,
|
|
ConstStructDb1, ConstStructDb),
|
|
poly_info_set_const_struct_db(ConstStructDb, !Info)
|
|
;
|
|
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),
|
|
(
|
|
ConstStructEnabled = yes,
|
|
all_are_const_struct_args(ArgVarsMCAs, VarConstArgs)
|
|
->
|
|
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),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
% XXX The UnifyContext is wrong.
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
TypeClassInfoRHS = rhs_functor(ConstConsId, no, []),
|
|
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.
|
|
InstResults = inst_test_results(inst_result_is_ground,
|
|
inst_result_does_not_contain_any,
|
|
inst_result_contains_instnames_known(set.init),
|
|
inst_result_contains_types_known(set.init)),
|
|
TypeClassInfoInst = bound(shared, InstResults,
|
|
[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]
|
|
;
|
|
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, no, AllArgVars),
|
|
UniMode = (free - ground(shared, none) ->
|
|
ground(shared, none) - ground(shared, none)),
|
|
list.length(AllArgVars, NumArgs),
|
|
list.duplicate(NumArgs, UniMode, UniModes),
|
|
Unification = construct(TypeClassInfoVar, ConsId, AllArgVars, UniModes,
|
|
construct_dynamically, cell_is_unique, no_construct_sub_info),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
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(shared, none), 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_instnames_known(set.init),
|
|
inst_result_contains_types_unknown),
|
|
% 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, SuperClassProofs, ExistQVars,
|
|
SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info) :-
|
|
poly_info_get_proofs(!.Info, Proofs),
|
|
|
|
poly_info_get_typevarset(!.Info, TVarSet0),
|
|
SuperClasses0 = ClassDefn ^ class_supers,
|
|
ClassVars0 = ClassDefn ^ class_vars,
|
|
ClassTVarSet = ClassDefn ^ class_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_proofs(SuperClassProofs, !Info),
|
|
make_superclasses_from_proofs(SuperClasses, ExistQVars,
|
|
SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info),
|
|
poly_info_set_proofs(Proofs, !Info).
|
|
|
|
:- pred make_superclasses_from_proofs(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_superclasses_from_proofs([], _, [], [], !Info).
|
|
make_superclasses_from_proofs([Constraint | Constraints], ExistQVars,
|
|
[TypeClassInfoVarMCA | TypeClassInfoVarsMCAs], Goals, !Info) :-
|
|
term.context_init(Context),
|
|
make_typeclass_info_var(Constraint, [], ExistQVars, Context,
|
|
TypeClassInfoVarMCA, HeadGoals, !Info),
|
|
make_superclasses_from_proofs(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,
|
|
list(prog_var)::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
make_existq_typeclass_info_vars(ExistentialConstraints, 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), 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, tvar::in,
|
|
list(hlds_goal)::in, list(hlds_goal)::out, poly_info::in, poly_info::out)
|
|
is det.
|
|
|
|
polymorphism_maybe_extract_type_info(OldRttiVarMaps, TVar, !ExtraGoals,
|
|
!Info) :-
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps),
|
|
(
|
|
rtti_search_type_info_locn(OldRttiVarMaps, TVar,
|
|
type_info(TypeInfoVar0)),
|
|
rtti_search_type_info_locn(RttiVarMaps, TVar,
|
|
typeclass_info(TypeClassInfoVar, Index))
|
|
->
|
|
polymorphism_extract_type_info(TVar, TypeClassInfoVar, Index, NewGoals,
|
|
TypeInfoVar1, !Info),
|
|
assign_var(TypeInfoVar0, TypeInfoVar1, AssignGoal),
|
|
!:ExtraGoals = NewGoals ++ [AssignGoal | !.ExtraGoals]
|
|
;
|
|
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).
|
|
( type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) ->
|
|
% 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)
|
|
;
|
|
(
|
|
( 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, 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),
|
|
(
|
|
map.search(TypeInfoVarMap0, TypeCtor, TypeCtorVarMap0),
|
|
map.search(TypeCtorVarMap0, TypeArgs, OldTypeInfoVarMCA)
|
|
->
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
TypeInfoVarMCA = OldTypeInfoVarMCA,
|
|
ExtraGoals = []
|
|
;
|
|
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),
|
|
( map.search(TypeInfoVarMap1, TypeCtor, TypeCtorVarMap1) ->
|
|
map.det_insert(TypeArgs, TypeInfoVarMCA,
|
|
TypeCtorVarMap1, TypeCtorVarMap),
|
|
map.det_update(TypeCtor, TypeCtorVarMap,
|
|
TypeInfoVarMap1, TypeInfoVarMap)
|
|
;
|
|
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),
|
|
( map.search(ConstStructVarMap0, TypeCtorConsIdConstArg, OldTypeCtorVar) ->
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
TypeCtorVar = OldTypeCtorVar,
|
|
TypeCtorGoals = [],
|
|
VarSet1 = VarSet0,
|
|
VarTypes1 = VarTypes0,
|
|
RttiVarMaps1 = RttiVarMaps0
|
|
;
|
|
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_and_types(VarSet1, VarTypes1, !Info),
|
|
poly_info_set_rtti_varmaps(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, 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.
|
|
|
|
(
|
|
% Unfortunately, if the type's type constructor has variable arity,
|
|
% we cannot use a one-cell representation for that type.
|
|
TypeCtorIsVarArity = no,
|
|
ArgTypeInfoVarsMCAs = []
|
|
->
|
|
% 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_and_types(VarSet1, VarTypes, !Info)
|
|
;
|
|
% 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),
|
|
(
|
|
Enabled = yes,
|
|
all_are_const_struct_args(ArgTypeInfoVarsMCAs,
|
|
ArgTypeInfoConstArgs)
|
|
->
|
|
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),
|
|
(
|
|
TypeCtorIsVarArity = 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]
|
|
;
|
|
TypeCtorIsVarArity = no,
|
|
StructConstArgs = [TypeCtorConstArg | ArgTypeInfoConstArgs],
|
|
StructArgInsts = [TypeCtorInst | ArgTypeInfoInsts]
|
|
),
|
|
StructType = type_info_type,
|
|
list.length(ArgTypeInfoConstArgs, 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),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
TypeInfoRHS = rhs_functor(type_info_const(ConstNum), no, []),
|
|
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.
|
|
InstResults = inst_test_results(inst_result_is_ground,
|
|
inst_result_does_not_contain_any,
|
|
inst_result_contains_instnames_known(set.init),
|
|
inst_result_contains_types_known(set.init)),
|
|
VarInst = bound(shared, InstResults,
|
|
[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]
|
|
;
|
|
assoc_list.keys(ArgTypeInfoVarsMCAs, ArgTypeInfoVars),
|
|
(
|
|
TypeCtorIsVarArity = 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]
|
|
;
|
|
TypeCtorIsVarArity = 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_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
|
|
MCA = no
|
|
)
|
|
).
|
|
|
|
get_special_proc(Type, SpecialPredId, ModuleInfo, PredName, PredId, ProcId) :-
|
|
TypeCategory = classify_type(ModuleInfo, Type),
|
|
get_category_name(TypeCategory) = MaybeCategoryName,
|
|
(
|
|
MaybeCategoryName = no,
|
|
module_info_get_special_pred_map(ModuleInfo, SpecialPredMap),
|
|
type_to_ctor_det(Type, TypeCtor),
|
|
map.search(SpecialPredMap, SpecialPredId - TypeCtor, PredId),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
PredName = qualified(Module, Name),
|
|
special_pred_mode_num(SpecialPredId, ProcInt),
|
|
proc_id_to_int(ProcId, ProcInt)
|
|
;
|
|
MaybeCategoryName = yes(CategoryName),
|
|
special_pred_name_arity(SpecialPredId, SpecialName, _, Arity),
|
|
Name = "builtin_" ++ SpecialName ++ "_" ++ CategoryName,
|
|
lookup_builtin_pred_proc_id(ModuleInfo, mercury_private_builtin_module,
|
|
Name, pf_predicate, Arity, only_mode, PredId, ProcId),
|
|
PredName = qualified(mercury_private_builtin_module, Name)
|
|
).
|
|
|
|
get_special_proc_det(Type, SpecialPredId, ModuleInfo, PredName,
|
|
PredId, ProcId) :-
|
|
(
|
|
get_special_proc(Type, SpecialPredId, ModuleInfo,
|
|
PredNamePrime, PredIdPrime, ProcIdPrime)
|
|
->
|
|
PredName = PredNamePrime,
|
|
PredId = PredIdPrime,
|
|
ProcId = ProcIdPrime
|
|
;
|
|
unexpected($module, $pred, "get_special_proc failed")
|
|
).
|
|
|
|
:- func get_category_name(type_ctor_category) = maybe(string).
|
|
|
|
get_category_name(CtorCat) = MaybeName :-
|
|
(
|
|
CtorCat = ctor_cat_builtin(cat_builtin_int),
|
|
MaybeName = yes("int")
|
|
;
|
|
CtorCat = ctor_cat_builtin(cat_builtin_char),
|
|
MaybeName = yes("character")
|
|
;
|
|
CtorCat = ctor_cat_builtin(cat_builtin_float),
|
|
MaybeName = yes("float")
|
|
;
|
|
CtorCat = ctor_cat_builtin(cat_builtin_string),
|
|
MaybeName = yes("string")
|
|
;
|
|
CtorCat = ctor_cat_higher_order,
|
|
MaybeName = yes("pred")
|
|
;
|
|
CtorCat = ctor_cat_tuple,
|
|
MaybeName = yes("tuple")
|
|
;
|
|
( CtorCat = ctor_cat_enum(_)
|
|
; CtorCat = ctor_cat_builtin_dummy
|
|
; CtorCat = ctor_cat_user(_)
|
|
; CtorCat = ctor_cat_system(_)
|
|
),
|
|
MaybeName = no
|
|
;
|
|
CtorCat = ctor_cat_variable,
|
|
unexpected($module, $pred, "variable type")
|
|
;
|
|
CtorCat = ctor_cat_void,
|
|
unexpected($module, $pred, "void_type")
|
|
).
|
|
|
|
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, no, 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.
|
|
UniMode = (free - ground(shared, none) ->
|
|
ground(shared, none) - ground(shared, none)),
|
|
list.length(ArgVars, NumArgVars),
|
|
list.duplicate(NumArgVars, UniMode, UniModes),
|
|
Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes,
|
|
construct_dynamically, cell_is_unique, no_construct_sub_info),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
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(shared, none), 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_instnames_known(set.init),
|
|
inst_result_contains_types_unknown),
|
|
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, no, []),
|
|
Unification = construct(TypeCtorInfoVar, ConsId, [], [],
|
|
construct_dynamically, cell_is_shared, no_construct_sub_info),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
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) :-
|
|
get_tvar_kind(!.Info ^ poly_tvar_kinds, TypeVar, Kind),
|
|
Type = type_variable(TypeVar, Kind),
|
|
new_type_info_var(Type, type_info, Var, !Info),
|
|
( varset.search_name(TypeVarSet, TypeVar, TypeVarName) ->
|
|
poly_info_get_varset(!.Info, VarSet0),
|
|
VarName = "TypeInfo_for_" ++ TypeVarName,
|
|
varset.name_var(Var, VarName, VarSet0, VarSet),
|
|
poly_info_set_varset(VarSet, !Info)
|
|
;
|
|
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_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(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.
|
|
(
|
|
rtti_search_type_info_locn(!.Info ^ poly_rtti_varmaps, TypeVar,
|
|
TypeInfoLocnPrime)
|
|
->
|
|
TypeInfoLocn = TypeInfoLocnPrime
|
|
;
|
|
% 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.
|
|
|
|
get_tvar_kind(!.Info ^ poly_tvar_kinds, TypeVar, Kind),
|
|
Type = type_variable(TypeVar, Kind),
|
|
new_type_info_var(Type, type_info, Var, !Info),
|
|
TypeInfoLocn = type_info(Var),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_det_insert_type_info_locn(TypeVar, TypeInfoLocn,
|
|
RttiVarMaps0, 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_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
|
|
|
|
get_type_info_from_locn(TypeVar, TypeInfoLocn, 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,
|
|
ExtraGoals, Var, !Info)
|
|
).
|
|
|
|
:- pred polymorphism_extract_type_info(tvar::in, prog_var::in, int::in,
|
|
list(hlds_goal)::out, prog_var::out, poly_info::in, poly_info::out) is det.
|
|
|
|
polymorphism_extract_type_info(TypeVar, TypeClassInfoVar, Index, 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_kinds(!.Info, TVarKinds),
|
|
get_tvar_kind(TVarKinds, TypeVar, Kind),
|
|
IndexIntOrVar = iov_var(IndexVar),
|
|
gen_extract_type_info(ModuleInfo, TypeVar, Kind, TypeClassInfoVar,
|
|
IndexIntOrVar, ExtractGoals, TypeInfoVar,
|
|
VarSet0, VarSet, VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
|
|
Goals = IndexGoals ++ ExtractGoals,
|
|
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
|
|
|
|
gen_extract_type_info(ModuleInfo, TypeVar, Kind, TypeClassInfoVar,
|
|
IndexIntOrVar, 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(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), ModuleInfo, term.context_init,
|
|
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),
|
|
( map.search(IntConstMap0, IntConst, IntVarPrime) ->
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
IntVar = IntVarPrime,
|
|
Goals = []
|
|
;
|
|
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_and_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) :-
|
|
(
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
|
|
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
|
|
OldTypeClassInfoVar)
|
|
->
|
|
TypeClassInfoVar = OldTypeClassInfoVar
|
|
;
|
|
% 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 ^ class_supers,
|
|
list.length(SuperClasses, NumSuperClasses),
|
|
|
|
% Find all the type variables in the constraint, and remember what
|
|
% index they appear in 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),
|
|
( rtti_search_type_info_locn(RttiVarMaps0, TypeVar, TypeInfoLocn) ->
|
|
TypeInfoLocn = type_info(_)
|
|
;
|
|
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_and_types(VarSet, VarTypes, !Info),
|
|
poly_info_set_rtti_varmaps(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.
|
|
( type_has_variable_arity_ctor(Type, _, _) ->
|
|
% We cannot use a plain type_ctor_info because we need to
|
|
% record the arity.
|
|
TypeInfoType = type_info_type
|
|
; type_to_ctor_and_args(Type, _Ctor, Args) ->
|
|
(
|
|
Args = [],
|
|
TypeInfoType = type_ctor_info_type
|
|
;
|
|
Args = [_ | _],
|
|
TypeInfoType = type_info_type
|
|
)
|
|
;
|
|
% 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
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% 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.
|
|
%
|
|
:- pred expand_class_method_bodies(module_info::in, module_info::out) is det.
|
|
|
|
expand_class_method_bodies(!ModuleInfo) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes),
|
|
module_info_get_name(!.ModuleInfo, ModuleName),
|
|
map.keys(Classes, 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, Classes, ClassDefns),
|
|
list.foldl(expand_class_method_bodies_2, 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_2(hlds_class_defn::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
expand_class_method_bodies_2(ClassDefn, !ModuleInfo) :-
|
|
Interface = ClassDefn ^ class_hlds_interface,
|
|
list.foldl2(expand_class_method_body, Interface, 1, _, !ModuleInfo).
|
|
|
|
:- pred expand_class_method_body(hlds_class_proc::in, int::in, int::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
expand_class_method_body(hlds_class_proc(PredId, ProcId), !ProcNum,
|
|
!ModuleInfo) :-
|
|
module_info_get_preds(!.ModuleInfo, PredTable0),
|
|
map.lookup(PredTable0, PredId, PredInfo0),
|
|
pred_info_get_procedures(PredInfo0, ProcTable0),
|
|
map.lookup(ProcTable0, ProcId, ProcInfo0),
|
|
|
|
% 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),
|
|
( ClassContext = constraints([Head | _], _) ->
|
|
InstanceConstraint = Head
|
|
;
|
|
unexpected($module, $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_remove_predid(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).
|
|
(
|
|
list.nth_member_search(HeadVars0, TypeClassInfoVar, N),
|
|
delete_nth(HeadVars0, N, HeadVarsPrime),
|
|
delete_nth(Modes0, N, ModesPrime)
|
|
->
|
|
HeadVars = HeadVarsPrime,
|
|
Modes = ModesPrime
|
|
;
|
|
unexpected($module, $pred, "typeclass_info var not found")
|
|
),
|
|
|
|
InstanceConstraint = constraint(ClassName, InstanceArgs),
|
|
list.length(InstanceArgs, InstanceArity),
|
|
pred_info_get_call_id(PredInfo0, CallId),
|
|
BodyGoalExpr = generic_call(
|
|
class_method(TypeClassInfoVar, !.ProcNum,
|
|
class_id(ClassName, InstanceArity), CallId),
|
|
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(HeadVars0, Modes0, !.ModuleInfo,
|
|
InstmapDelta),
|
|
pred_info_get_purity(PredInfo0, Purity),
|
|
goal_info_init(NonLocals, InstmapDelta, Detism, Purity, GoalInfo),
|
|
BodyGoal = hlds_goal(BodyGoalExpr, GoalInfo),
|
|
|
|
proc_info_set_goal(BodyGoal, ProcInfo0, ProcInfo),
|
|
map.det_update(ProcId, ProcInfo, ProcTable0, ProcTable),
|
|
pred_info_set_procedures(ProcTable, PredInfo0, PredInfo1),
|
|
( pred_info_is_imported(PredInfo1) ->
|
|
pred_info_set_import_status(status_opt_imported, PredInfo1, PredInfo)
|
|
;
|
|
PredInfo = PredInfo1
|
|
),
|
|
|
|
map.det_update(PredId, PredInfo, PredTable0, PredTable),
|
|
module_info_set_preds(PredTable, !ModuleInfo),
|
|
|
|
!:ProcNum = !.ProcNum + 1.
|
|
|
|
:- pred delete_nth(list(T)::in, int::in, list(T)::out) is semidet.
|
|
|
|
delete_nth([X | Xs], N0, Result) :-
|
|
( N0 > 1 ->
|
|
N = N0 - 1,
|
|
delete_nth(Xs, N, TheRest),
|
|
Result = [X | TheRest]
|
|
;
|
|
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),
|
|
( map.search(ConstStructVarMap0, ConstArg, OldVar) ->
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
Var = OldVar,
|
|
Goals = []
|
|
;
|
|
new_typeclass_info_var(Constraint, base_typeclass_info_kind, Var,
|
|
_VarType, !Info),
|
|
|
|
% Create the construction unification to initialize the variable.
|
|
RHS = rhs_functor(ConsId, no, []),
|
|
Unification = construct(Var, ConsId, [], [],
|
|
construct_dynamically, cell_is_shared, no_construct_sub_info),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
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),
|
|
( map.search(ConstStructVarMap0, InstanceIdConstArg, OldVar) ->
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
Var = OldVar,
|
|
Goals = []
|
|
;
|
|
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, no, []),
|
|
Unification = construct(Var, ConsId, [], [],
|
|
construct_statically, cell_is_shared, no_construct_sub_info),
|
|
UnifyMode = (free -> ground(shared, none)) -
|
|
(ground(shared, none) -> ground(shared, none)),
|
|
UnifyContext = unify_context(umc_explicit, []),
|
|
% XXX The UnifyContext is wrong.
|
|
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(
|
|
% The first two fields are from the proc_info.
|
|
poly_varset :: prog_varset,
|
|
poly_vartypes :: vartypes,
|
|
|
|
% The next two fields from the pred_info.
|
|
poly_typevarset :: tvarset,
|
|
poly_tvar_kinds :: tvar_kind_map,
|
|
|
|
% Gives information about the locations of type_infos
|
|
% and typeclass_infos.
|
|
poly_rtti_varmaps :: rtti_varmaps,
|
|
|
|
% 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,
|
|
|
|
poly_pred_info :: pred_info,
|
|
poly_module_info :: module_info
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% 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_kinds(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proofs(PredInfo, Proofs),
|
|
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),
|
|
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
|
|
RttiVarMaps, Proofs, ConstraintMap,
|
|
TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, PredInfo, ModuleInfo).
|
|
|
|
% Create_poly_info creates a poly_info for an existing procedure.
|
|
% (See also init_poly_info.)
|
|
%
|
|
create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
|
|
pred_info_get_typevarset(PredInfo, TypeVarSet),
|
|
pred_info_get_tvar_kinds(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proofs(PredInfo, Proofs),
|
|
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),
|
|
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
|
|
RttiVarMaps, Proofs, ConstraintMap, TypeInfoVarMap,
|
|
TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, PredInfo, ModuleInfo).
|
|
|
|
poly_info_extract(Info, !PredInfo, !ProcInfo, !:ModuleInfo) :-
|
|
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
|
|
RttiVarMaps, _Proofs, _ConstraintMap,
|
|
_TypeInfoVarMap, _TypeClassInfoMap, _IntConstMap, _ConstStructVarMap,
|
|
_NumReuses, _SnapshotNum, ConstStructDb, _OldPredInfo, !:ModuleInfo),
|
|
|
|
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_kinds(TypeVarKinds, !PredInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- 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_typevarset(poly_info::in, tvarset::out) is det.
|
|
:- pred poly_info_get_tvar_kinds(poly_info::in, tvar_kind_map::out) is det.
|
|
:- pred poly_info_get_rtti_varmaps(poly_info::in, rtti_varmaps::out) is det.
|
|
:- pred poly_info_get_proofs(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_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_const_struct_var_map(poly_info::in,
|
|
const_struct_var_map::out) is det.
|
|
:- pred poly_info_get_pred_info(poly_info::in, pred_info::out) is det.
|
|
:- pred poly_info_get_module_info(poly_info::in, module_info::out) is det.
|
|
|
|
poly_info_get_varset(PolyInfo, PolyInfo ^ poly_varset).
|
|
poly_info_get_var_types(PolyInfo, PolyInfo ^ poly_vartypes).
|
|
poly_info_get_typevarset(PolyInfo, PolyInfo ^ poly_typevarset).
|
|
poly_info_get_tvar_kinds(PolyInfo, PolyInfo ^ poly_tvar_kinds).
|
|
poly_info_get_rtti_varmaps(PolyInfo, PolyInfo ^ poly_rtti_varmaps).
|
|
poly_info_get_proofs(PolyInfo, PolyInfo ^ poly_proof_map).
|
|
poly_info_get_constraint_map(PolyInfo, PolyInfo ^ poly_constraint_map).
|
|
poly_info_get_type_info_var_map(PolyInfo, PolyInfo ^ poly_type_info_var_map).
|
|
poly_info_get_typeclass_info_map(PolyInfo, PolyInfo ^ poly_typeclass_info_map).
|
|
poly_info_get_int_const_map(PolyInfo, PolyInfo ^ poly_int_const_map).
|
|
poly_info_get_num_reuses(PolyInfo, PolyInfo ^ poly_num_reuses).
|
|
poly_info_get_const_struct_db(PolyInfo, PolyInfo ^ poly_const_struct_db).
|
|
poly_info_get_const_struct_var_map(PolyInfo,
|
|
PolyInfo ^ poly_const_struct_var_map).
|
|
poly_info_get_pred_info(PolyInfo, PolyInfo ^ poly_pred_info).
|
|
poly_info_get_module_info(PolyInfo, PolyInfo ^ poly_module_info).
|
|
|
|
:- pred poly_info_set_varset(prog_varset::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_varset_and_types(prog_varset::in, vartypes::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_tvar_kinds(tvar_kind_map::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_proofs(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_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_const_struct_var_map(const_struct_var_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
poly_info_set_varset(VarSet, !PI) :-
|
|
!PI ^ poly_varset := VarSet.
|
|
poly_info_set_varset_and_types(VarSet, VarTypes, !PI) :-
|
|
!PI ^ poly_varset := VarSet,
|
|
!PI ^ poly_vartypes := VarTypes.
|
|
poly_info_set_typevarset(TVarSet, !PI) :-
|
|
!PI ^ poly_typevarset := TVarSet.
|
|
poly_info_set_tvar_kinds(TVarKinds, !PI) :-
|
|
!PI ^ poly_tvar_kinds := TVarKinds.
|
|
poly_info_set_rtti_varmaps(RttiVarMaps, !PI) :-
|
|
!PI ^ poly_rtti_varmaps := RttiVarMaps.
|
|
poly_info_set_proofs(Proofs, !PI) :-
|
|
!PI ^ poly_proof_map := Proofs.
|
|
poly_info_set_type_info_var_map(TypeInfoVarMap, !PI) :-
|
|
!PI ^ poly_type_info_var_map := TypeInfoVarMap.
|
|
poly_info_set_typeclass_info_map(TypeClassInfoMap, !PI) :-
|
|
!PI ^ poly_typeclass_info_map := TypeClassInfoMap.
|
|
poly_info_set_int_const_map(IntConstMap, !PI) :-
|
|
!PI ^ poly_int_const_map := IntConstMap.
|
|
poly_info_set_num_reuses(NumReuses, !PI) :-
|
|
!PI ^ poly_num_reuses := NumReuses.
|
|
poly_info_set_const_struct_db(ConstStructDb, !PI) :-
|
|
!PI ^ poly_const_struct_db := ConstStructDb.
|
|
poly_info_set_const_struct_var_map(ConstStructVarMap, !PI) :-
|
|
!PI ^ poly_const_struct_var_map := ConstStructVarMap.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- 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.
|
|
:- pred set_cache_maps_snapshot(string::in, cache_maps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred empty_cache_maps(poly_info::in, poly_info::out) is det.
|
|
|
|
get_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
SnapshotNum = !.Info ^ poly_snapshot_num,
|
|
TypeInfoVarMap = !.Info ^ poly_type_info_var_map,
|
|
TypeClassInfoMap = !.Info ^ poly_typeclass_info_map,
|
|
IntConstMap = !.Info ^ poly_int_const_map,
|
|
ConstStructVarMap = !.Info ^ poly_const_struct_var_map,
|
|
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),
|
|
(
|
|
SelectedPred = yes,
|
|
Name \= ""
|
|
->
|
|
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),
|
|
NumVars = varset.num_allocated(!.Info ^ poly_varset),
|
|
io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO)
|
|
;
|
|
true
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
set_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
|
|
IntConstMap, ConstStructVarMap),
|
|
!Info ^ poly_type_info_var_map := TypeInfoVarMap,
|
|
!Info ^ poly_typeclass_info_map := TypeClassInfoMap,
|
|
!Info ^ poly_int_const_map := IntConstMap,
|
|
!Info ^ 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),
|
|
(
|
|
SelectedPred = yes,
|
|
Name \= ""
|
|
->
|
|
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),
|
|
NumVars = varset.num_allocated(!.Info ^ poly_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)
|
|
;
|
|
true
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
empty_cache_maps(!Info) :-
|
|
!Info ^ poly_type_info_var_map := map.init,
|
|
!Info ^ poly_typeclass_info_map := map.init,
|
|
!Info ^ poly_int_const_map := map.init,
|
|
!Info ^ poly_const_struct_var_map := map.init.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- 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,
|
|
VarSet = !.Info ^ poly_varset,
|
|
VarTypes = !.Info ^ poly_vartypes,
|
|
RttiVarMaps = !.Info ^ poly_rtti_varmaps,
|
|
|
|
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("get_var_maps_snapshot %d %s\n",
|
|
[i(SnapshotNum), s(Name)], !IO),
|
|
io.write_string(IndentStr, !IO),
|
|
NumVars = varset.num_allocated(VarSet),
|
|
io.format("num_allocated vars: %d\n\n", [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)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
|
|
!Info ^ poly_varset := VarSet,
|
|
!Info ^ poly_vartypes := VarTypes,
|
|
!Info ^ poly_rtti_varmaps := RttiVarMaps,
|
|
set_cache_maps_snapshot("", CacheMaps, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.polymorphism.
|
|
%---------------------------------------------------------------------------%
|