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