%-----------------------------------------------------------------------------% % 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 % word 1+ % % (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 % word 1 % word 2+ % %-----------------------------------------------------------------------------% % % 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. %---------------------------------------------------------------------------%