%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %---------------------------------------------------------------------------% % Copyright (C) 1994-2012 The University of Melbourne. % Copyright (C) 2015-2018, 2020-2021 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: unify_proc.m. % % This module generates the bodies of the unify, compare and index predicates % that the compiler automatically creates for each type definition. % % We can sometimes do this without knowing the representation of the type. % For example, if the type has user has specified the predicates by which % two values of the type should be unified or compared, then the automatically % generated clauses need only call the specified predicates. % % However, in many cases, we *do* need to know the representation of the type. % For example, we need that information % % - to decide whether an eqv type is equivalent to a dummy type; % - to decide whether arguments of a functor of a du type are dummies; and % - to decide what code to generate for a unify or compare pred for du % %---------------------------------------------------------------------------% % % This module has five main sections. % % The first section distributes the work between the next three sections. % % The middle three sections generate the definitions of unify, compare % and index predicates respectively. Each of these sections handles % the various kinds of type definitions in the same order. % % The last section contains utility predicates. % %---------------------------------------------------------------------------% :- module check_hlds.unify_proc. :- interface. :- import_module hlds. :- import_module hlds.hlds_clauses. :- import_module hlds.hlds_data. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. :- import_module hlds.status. :- import_module mdbcomp. :- import_module mdbcomp.prim_data. :- import_module parse_tree. :- import_module parse_tree.prog_data. %---------------------------------------------------------------------------% :- type spec_pred_defn_info ---> spec_pred_defn_info( spdi_spec_pred_id :: special_pred_id, spdi_pred_id :: pred_id, spdi_tvarset :: tvarset, spdi_type :: mer_type, spdi_type_ctor :: type_ctor, spdi_type_body :: hlds_type_body, spdi_orig_status :: type_status, spdi_context :: prog_context ). % Generate the clauses for one of the compiler-generated special predicates % (unify2, compare/3 and index/2) for a type constructor. % % We will return a modified module_info if the code we generate for % the given special_pred requires the definition of another special_pred % that is not defined by default. % % Right now, this will happen only if a comparison predicate needs % the use of an index predicate. % :- pred generate_clauses_for_special_pred(spec_pred_defn_info::in, clauses_info::out, module_info::in, module_info::out) is det. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- implementation. :- import_module check_hlds.type_util. :- import_module hlds.add_special_pred. :- import_module hlds.goal_util. :- import_module hlds.hlds_args. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_rtti. :- import_module hlds.instmap. :- import_module hlds.make_goal. :- import_module hlds.pred_table. :- import_module hlds.quantification. :- import_module hlds.special_pred. :- import_module libs. :- import_module libs.globals. :- import_module libs.options. :- import_module mdbcomp.builtin_modules. :- 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_type. :- import_module parse_tree.prog_type_subst. :- import_module parse_tree.set_of_var. :- import_module parse_tree.var_table. :- import_module parse_tree.vartypes. :- import_module assoc_list. :- import_module bool. :- import_module int. :- import_module list. :- import_module map. :- import_module maybe. :- import_module pair. :- import_module require. :- import_module string. :- import_module term. :- import_module uint8. :- import_module varset. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% generate_clauses_for_special_pred(SpecDefnInfo, ClauseInfo, !ModuleInfo) :- SpecialPredId = SpecDefnInfo ^ spdi_spec_pred_id, Type = SpecDefnInfo ^ spdi_type, special_pred_interface(SpecialPredId, Type, ArgTypes, _Modes, _Det), some [!Info] ( info_init(!.ModuleInfo, !:Info), make_fresh_named_vars_from_types(ArgTypes, "HeadVar__", 1, ArgVars, !Info), ( SpecialPredId = spec_pred_unify, ( if ArgVars = [X, Y] then generate_unify_proc_body(SpecDefnInfo, X, Y, Clauses, !Info) else unexpected($pred, "bad unify args") ) ; SpecialPredId = spec_pred_index, ( if ArgVars = [X, Index] then generate_index_proc_body(SpecDefnInfo, X, Index, Clause, !Info) else unexpected($pred, "bad index args") ), Clauses = [Clause] ; SpecialPredId = spec_pred_compare, ( if ArgVars = [Res, X, Y] then generate_compare_proc_body(SpecDefnInfo, Res, X, Y, Clause, !Info) else unexpected($pred, "bad compare args") ), Clauses = [Clause] ), info_extract(!.Info, !:ModuleInfo, VarTable) ), split_var_table(VarTable, VarSet, VarTypes0), vartypes_to_sorted_assoc_list(VarTypes0, VarTypesAL0), get_explicitly_typed_vars(VarTypesAL0, [], RevExplicitVarTypesAL), vartypes_from_rev_sorted_assoc_list(RevExplicitVarTypesAL, ExplicitVarTypes), rtti_varmaps_init(RttiVarMaps), map.init(TVarNameMap), ArgVec = proc_arg_vector_init(pf_predicate, ArgVars), set_clause_list(Clauses, ClausesRep), % We fill in the VarSet and ExplicitVarTypes fields because typechecking % will need them. % XXX TYPE_REPN Should be no_foreign_lang_clauses ClauseInfo = clauses_info(VarSet, ExplicitVarTypes, VarTable, RttiVarMaps, TVarNameMap, ArgVec, ClausesRep, init_clause_item_numbers_comp_gen, some_foreign_lang_clauses, no_clause_syntax_errors). :- pred get_explicitly_typed_vars(assoc_list(prog_var, mer_type)::in, assoc_list(prog_var, mer_type)::in, assoc_list(prog_var, mer_type)::out) is det. get_explicitly_typed_vars([], !RevVarsTypes). get_explicitly_typed_vars([Var - Type | VarsTypes], !RevVarsTypes) :- ( if Type = void_type then true else !:RevVarsTypes = [Var - Type | !.RevVarsTypes] ), get_explicitly_typed_vars(VarsTypes, !RevVarsTypes). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% % % Generate clauses for unify predicates. % :- pred generate_unify_proc_body(spec_pred_defn_info::in, prog_var::in, prog_var::in, list(clause)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body(SpecDefnInfo, X, Y, Clauses, !Info) :- info_get_module_info(!.Info, ModuleInfo), TypeBody = SpecDefnInfo ^ spdi_type_body, Context = SpecDefnInfo ^ spdi_context, ( if TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, subtype_of(SuperType), _, _, _) then % Unify subtype terms after casting to base type. % This is necessary in high-level data grades, % and saves some code in low-level data grades. TVarSet = SpecDefnInfo ^ spdi_tvarset, get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType), generate_unify_proc_body_eqv(Context, BaseType, X, Y, Clause, !Info), Clauses = [Clause] else if % We used to special-case the type_ctors for which % is_type_ctor_a_builtin_dummy(TypeCtor) = is_builtin_dummy_type_ctor, % but both those types now have user-defined unify and compare preds. type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) then generate_unify_proc_body_user(UserEqComp, X, Y, Context, Clause, !Info), Clauses = [Clause] else ( TypeBody = hlds_abstract_type(_), % There is no way we can generate unify, index or compare % predicates for actual abstract types. Having our ancestor % pass hlds_abstract_type here is a special in-band signal % that the type is actually a builtin type. ( if compiler_generated_rtti_for_builtins(ModuleInfo) then generate_unify_proc_body_builtin(SpecDefnInfo, X, Y, Clause, !Info) else unexpected($pred, "trying to create unify proc for abstract type") ), Clauses = [Clause] ; TypeBody = hlds_eqv_type(EqvType), EqvIsDummy = is_type_a_dummy(ModuleInfo, EqvType), ( EqvIsDummy = is_dummy_type, % Treat this type as if it were a dummy type itself. generate_unify_proc_body_dummy(Context, X, Y, Clause, !Info) ; EqvIsDummy = is_not_dummy_type, generate_unify_proc_body_eqv(Context, EqvType, X, Y, Clause, !Info) ), Clauses = [Clause] ; TypeBody = hlds_foreign_type(_), % If no user defined equality predicate is given, % we treat foreign_types as if they were equivalent % to the builtin type c_pointer. generate_unify_proc_body_eqv(Context, c_pointer_type, X, Y, Clause, !Info), Clauses = [Clause] ; TypeBody = hlds_solver_type(_), generate_unify_proc_body_solver(Context, X, Y, Clause, !Info), Clauses = [Clause] ; TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, MaybeSuperType, _, MaybeRepn, _), expect(unify(MaybeSuperType, not_a_subtype), $pred, "MaybeSuperType != not_a_subtype"), ( MaybeRepn = no, unexpected($pred, "MaybeRepn = no") ; MaybeRepn = yes(Repn) ), DuTypeKind = Repn ^ dur_kind, ( ( DuTypeKind = du_type_kind_mercury_enum ; DuTypeKind = du_type_kind_foreign_enum(_) ), generate_unify_proc_body_enum(Context, X, Y, Clause, !Info), Clauses = [Clause] ; DuTypeKind = du_type_kind_direct_dummy, generate_unify_proc_body_dummy(Context, X, Y, Clause, !Info), Clauses = [Clause] ; DuTypeKind = du_type_kind_notag(_, ArgType, _), ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType), ( ArgIsDummy = is_dummy_type, % Treat this type as if it were a dummy type % itself. generate_unify_proc_body_dummy(Context, X, Y, Clause, !Info), Clauses = [Clause] ; ArgIsDummy = is_not_dummy_type, CtorRepns = Repn ^ dur_ctor_repns, generate_unify_proc_body_du(SpecDefnInfo, CtorRepns, X, Y, Clauses, !Info) ) ; DuTypeKind = du_type_kind_general, CtorRepns = Repn ^ dur_ctor_repns, generate_unify_proc_body_du(SpecDefnInfo, CtorRepns, X, Y, Clauses, !Info) ) ) ). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_dummy(prog_context::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_dummy(Context, X, Y, Clause, !Info) :- Goal = true_goal_with_context(Context), quantify_clause_body(all_modes, [X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_user(noncanonical::in, prog_var::in, prog_var::in, prog_context::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_user(NonCanonical, X, Y, Context, Clause, !Info) :- ( NonCanonical = noncanon_abstract(_IsSolverType), unexpected($pred, "trying to create unify proc for abstract noncanonical type") ; NonCanonical = noncanon_subtype, unexpected($pred, "trying to create unify proc for subtype") ; ( NonCanonical = noncanon_uni_cmp(UnifyPredName, _) ; NonCanonical = noncanon_uni_only(UnifyPredName) ), % Just generate a call to the specified predicate, which is the % user-defined equality pred for this type. (The pred_id and proc_id % will be figured out by type checking and mode analysis.) PredId = invalid_pred_id, ModeId = invalid_proc_id, Call = plain_call(PredId, ModeId, [X, Y], not_builtin, no, UnifyPredName), goal_info_init(Context, GoalInfo), Goal0 = hlds_goal(Call, GoalInfo) ; NonCanonical = noncanon_cmp_only(ComparePredName), % Just generate a call to the specified predicate, which is the % user-defined comparison pred for this type, and unify the result % with `='. (The pred_id and proc_id will be figured out by type % checking and mode analysis.) info_new_var("Result", comparison_result_type, ResultVar, !Info), PredId = invalid_pred_id, ModeId = invalid_proc_id, Call = plain_call(PredId, ModeId, [ResultVar, X, Y], not_builtin, no, ComparePredName), goal_info_init(Context, GoalInfo), CallGoal = hlds_goal(Call, GoalInfo), create_pure_atomic_complicated_unification(ResultVar, compare_functor("="), Context, umc_explicit, [], UnifyGoal), Goal0 = hlds_goal(conj(plain_conj, [CallGoal, UnifyGoal]), GoalInfo) ), % XXX If the user-specified unify (or compare) predicate always aborts, % we should avoid a pretest, since if it accidentally happens to succeeed, % it avoids the requested abort. maybe_wrap_with_pretest_equality(Context, X, Y, no, Goal0, Goal, !Info), quantify_clause_body(all_modes, [X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_builtin(spec_pred_defn_info::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_builtin(SpecDefnInfo, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, CtorCat = classify_type_ctor(ModuleInfo, TypeCtor), ArgVars = [X, Y], % can_generate_special_pred_clauses_for_type ensures the unexpected % cases can never occur. ( CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int)), Name = "builtin_unify_int" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint)), Name = "builtin_unify_uint" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int8)), Name = "builtin_unify_int8" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint8)), Name = "builtin_unify_uint8" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int16)), Name = "builtin_unify_int16" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint16)), Name = "builtin_unify_uint16" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int32)), Name = "builtin_unify_int32" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint32)), Name = "builtin_unify_uint32" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int64)), Name = "builtin_unify_int64" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint64)), Name = "builtin_unify_uint64" ; CtorCat = ctor_cat_builtin(cat_builtin_char), Name = "builtin_unify_character" ; CtorCat = ctor_cat_builtin(cat_builtin_string), Name = "builtin_unify_string" ; CtorCat = ctor_cat_builtin(cat_builtin_float), Name = "builtin_unify_float" ; CtorCat = ctor_cat_higher_order, Name = "builtin_unify_pred" ; ( CtorCat = ctor_cat_tuple ; CtorCat = ctor_cat_enum(_) ; CtorCat = ctor_cat_builtin_dummy ; CtorCat = ctor_cat_variable ; CtorCat = ctor_cat_void ; CtorCat = ctor_cat_system(_) ; CtorCat = ctor_cat_user(_) ), unexpected($pred, "bad ctor category") ), Context = SpecDefnInfo ^ spdi_context, build_simple_call(ModuleInfo, mercury_private_builtin_module, Name, ArgVars, Context, UnifyGoal), quantify_clause_body(all_modes, ArgVars, UnifyGoal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_eqv(prog_context::in, mer_type::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_eqv(Context, EqvType, X, Y, Clause, !Info) :- % We should check whether EqvType is a type variable, % an abstract type or a concrete type. % If it is type variable, then we should generate the same code % we generate now. If it is an abstract type, we should call % its unification procedure directly; if it is a concrete type, % we should generate the body of its unification procedure % inline here. make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 1, CastX, !Info), make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 2, CastY, !Info), generate_cast(equiv_type_cast, X, CastX, Context, CastXGoal), generate_cast(equiv_type_cast, Y, CastY, Context, CastYGoal), create_pure_atomic_complicated_unification(CastX, rhs_var(CastY), Context, umc_explicit, [], UnifyGoal), goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal([CastXGoal, CastYGoal, UnifyGoal], GoalInfo, Goal), quantify_clause_body(all_modes, [X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_solver(prog_context::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_solver(Context, X, Y, Clause, !Info) :- ArgVars = [X, Y], info_get_module_info(!.Info, ModuleInfo), build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_unify_solver_type", ArgVars, Context, Goal), quantify_clause_body(all_modes, ArgVars, Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_unify_proc_body_enum(prog_context::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_enum(Context, X, Y, Clause, !Info) :- make_simple_test(X, Y, umc_explicit, [], Goal), quantify_clause_body(all_modes, [X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- type maybe_compare_constants_as_ints ---> do_not_compare_constants_as_ints ; compare_constants_as_ints. :- type maybe_allow_packed_unify_compare ---> do_not_allow_packed_unify_compare ; allow_packed_unify_compare. :- type uc_options ---> uc_options( uco_constants_as_ints :: maybe_compare_constants_as_ints, uco_packed_unify_compare :: maybe_allow_packed_unify_compare ). % Succeed iff the target back end guarantees that comparing two constants % for equality can be done by casting them both to integers and comparing % the integers for equality. % :- func lookup_unify_compare_options(unify_proc_info) = uc_options. lookup_unify_compare_options(Info) = UCOptions :- info_get_module_info(Info, ModuleInfo), module_info_get_globals(ModuleInfo, Globals), globals.lookup_bool_option(Globals, can_compare_constants_as_ints, BoolCanCompareAsInt), ( BoolCanCompareAsInt = no, CanCompareAsInt = do_not_compare_constants_as_ints ; BoolCanCompareAsInt = yes, CanCompareAsInt = compare_constants_as_ints ), globals.lookup_bool_option(Globals, allow_packed_unify_compare, BoolAllowPackedUC), globals.get_target(Globals, Target), ( if BoolAllowPackedUC = yes, % The foreign_procs we generate are all in C. Target = target_c then AllowPackedUC = allow_packed_unify_compare else AllowPackedUC = do_not_allow_packed_unify_compare ), UCOptions = uc_options(CanCompareAsInt, AllowPackedUC). %---------------------------------------------------------------------------% % generate_unify_proc_body_du: for a type such as % % :- type t % ---> a1 % ; a2 % ; b(int) % ; c(float) % ; d(int, string, t). % % we want to generate the code % % __Unify__(X, Y) :- % ( % X = a1, % Y = X % % Actually, to avoid infinite recursion, % % the above unification is done as type int: % % CastX = unsafe_cast(X) `with_type` int, % % CastY = unsafe_cast(Y) `with_type` int, % % CastX = CastY % ; % X = a2, % Y = X % Likewise, done as type int % ; % X = b(X1), % Y = b(Y2), % X1 = Y2, % ; % X = c(X1), % Y = c(Y1), % X1 = X2, % ; % X = d(X1, X2, X3), % Y = c(Y1, Y2, Y3), % X1 = y1, % X2 = Y2, % X3 = Y3 % ). % % Note that in the disjuncts handling constants, we want to unify Y with % X, not with the constant. Doing this allows dupelim to take the code % fragments implementing the switch arms for constants and eliminate all % but one of them. This can be a significant code size saving for types % with lots of constants, which can then lead to significant reductions in % C compilation time. The keep_constant_binding feature on the cast goals % is there to ask mode analysis to copy any known bound inst on the % cast-from variable to the cast-to variable. This is necessary to keep % determinism analysis working for modes in which the inputs of the unify % predicate are known to be bound to the same constant, modes whose % determinism should therefore be inferred to be det. % (tests/general/det_complicated_unify2.m tests this case.) % :- pred generate_unify_proc_body_du(spec_pred_defn_info::in, list(constructor_repn)::in, prog_var::in, prog_var::in, list(clause)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_unify_proc_body_du(SpecDefnInfo, CtorRepns, X, Y, Clauses, !Info) :- UCOptions = lookup_unify_compare_options(!.Info), Context = SpecDefnInfo ^ spdi_context, ( if UCOptions ^ uco_constants_as_ints = compare_constants_as_ints, UCOptions ^ uco_packed_unify_compare = allow_packed_unify_compare, MayUnifyCtorAsWhole = ( pred(CtorRepn::in) is semidet :- CtorRepn = ctor_repn(_, _, _, ConsTag, CtorArgRepns, _, _), ( CtorArgRepns = [] ; CtorArgRepns = [_ | _], ConsTag = local_args_tag(_) ) ), list.all_true(MayUnifyCtorAsWhole, CtorRepns) then CastType = get_pretest_equality_cast_type(!.Info), info_new_var("CastX", CastType, CastX, !Info), info_new_var("CastY", CastType, CastY, !Info), generate_cast(unsafe_type_cast, X, CastX, Context, CastXGoal), generate_cast(unsafe_type_cast, Y, CastY, Context, CastYGoal), create_pure_atomic_complicated_unification(CastX, rhs_var(CastY), Context, umc_explicit, [], EqualityGoal), GoalExpr = conj(plain_conj, [CastXGoal, CastYGoal, EqualityGoal]), goal_info_init(Context, GoalInfo), Goal = hlds_goal(GoalExpr, GoalInfo), % Casting X and Y to e.g. an integer when they contain arguments % is a kind of packed word operation. PackedOps = used_some_packed_word_ops else list.map_foldl(generate_du_unify_case(SpecDefnInfo, UCOptions, X, Y), CtorRepns, Disjuncts, !Info), goal_info_init(Context, GoalInfo), Goal0 = hlds_goal(disj(Disjuncts), GoalInfo), maybe_wrap_with_pretest_equality(Context, X, Y, no, Goal0, Goal, !Info), PackedOps = !.Info ^ upi_packed_ops ), % Did the clause we just generate use any bulk operations? ( PackedOps = used_no_packed_word_ops, % No: mark the clause as suitable for all modes. quantify_clause_body(all_modes, [X, Y], Goal, Context, Clause, !Info), Clauses = [Clause] ; PackedOps = used_some_packed_word_ops, % Yes: mark the clause as suitable only for modes, and ... quantify_clause_body(unify_in_in_modes, [X, Y], Goal, Context, InInClause, !Info), % ... generate another clause for non- modes for which % the generation of bulk comparisons is disabled. NonPackedUCOptions = UCOptions ^ uco_packed_unify_compare := do_not_allow_packed_unify_compare, !Info ^ upi_packed_ops := used_no_packed_word_ops, list.map_foldl( generate_du_unify_case(SpecDefnInfo, NonPackedUCOptions, X, Y), CtorRepns, NonPackedDisjuncts, !Info), expect(unify(!.Info ^ upi_packed_ops, used_no_packed_word_ops), $pred, "packed word ops show up after being disabled"), NonPackedGoal0 = hlds_goal(disj(NonPackedDisjuncts), GoalInfo), maybe_wrap_with_pretest_equality(Context, X, Y, no, NonPackedGoal0, NonPackedGoal, !Info), quantify_clause_body(unify_non_in_in_modes, [X, Y], NonPackedGoal, Context, NonInInClause, !Info), % The order of the clauses does not matter; clause_to_proc.m % will always pick or the other, never both. Clauses = [InInClause, NonInInClause] ). :- pred generate_du_unify_case(spec_pred_defn_info::in, uc_options::in, prog_var::in, prog_var::in, constructor_repn::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_du_unify_case(SpecDefnInfo, UCOptions, X, Y, CtorRepn, Goal, !Info) :- CtorRepn = ctor_repn(_Ordinal, MaybeExistConstraints, FunctorName, ConsTag, CtorArgRepns, FunctorArity, _Ctxt), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, ( if TypeCtor = type_ctor(unqualified("{}"), _) then FunctorConsId = tuple_cons(FunctorArity) else FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor) ), Context = SpecDefnInfo ^ spdi_context, compute_exist_constraint_implications(MaybeExistConstraints, ExistQTVars, GiveVarsTypes), ( if ( CtorArgRepns = [], UCOptions ^ uco_constants_as_ints = compare_constants_as_ints, % There are no arguments to compare. RHSVars = [] ; CtorArgRepns = [_ | _], ConsTag = local_args_tag(_), UCOptions ^ uco_packed_unify_compare = allow_packed_unify_compare, % There are arguments to compare, but they are stored % in the same word as the ptag and the sectag (if any). make_fresh_vars(GiveVarsTypes, "_Arg", CtorArgRepns, RHSVars, !Info), !Info ^ upi_packed_ops := used_some_packed_word_ops ) then RHS = rhs_functor(FunctorConsId, is_not_exist_constr, RHSVars), create_pure_atomic_complicated_unification(X, RHS, Context, umc_explicit, [], GoalUnifyX), info_new_var("CastX", int_type, CastX, !Info), info_new_var("CastY", int_type, CastY, !Info), generate_cast(unsafe_type_cast, X, CastX, Context, CastXGoal0), generate_cast(unsafe_type_cast, Y, CastY, Context, CastYGoal0), goal_add_feature(feature_keep_constant_binding, CastXGoal0, CastXGoal), goal_add_feature(feature_keep_constant_binding, CastYGoal0, CastYGoal), create_pure_atomic_complicated_unification(CastY, rhs_var(CastX), Context, umc_explicit, [], GoalUnifyY), GoalList = [GoalUnifyX, CastXGoal, CastYGoal, GoalUnifyY] else MaybePackableArgsLocn = compute_maybe_packable_args_locn(ConsTag), info_get_module_info(!.Info, ModuleInfo), UCParams = uc_params(ModuleInfo, Context, ExistQTVars, MaybePackableArgsLocn, GiveVarsTypes, UCOptions ^ uco_constants_as_ints, UCOptions ^ uco_packed_unify_compare), info_get_var_table(!.Info, VarTable0), lookup_var_type(VarTable0, X, TermType), FirstArgNum = 1, generate_arg_unify_goals(UCParams, TermType, X, Y, FirstArgNum, CtorArgRepns, UnifyArgsGoals, VarsX, VarsY, !Info), RHSX = rhs_functor(FunctorConsId, is_not_exist_constr, VarsX), RHSY = rhs_functor(FunctorConsId, is_not_exist_constr, VarsY), create_pure_atomic_complicated_unification(X, RHSX, Context, umc_explicit, [], GoalUnifyX), create_pure_atomic_complicated_unification(Y, RHSY, Context, umc_explicit, [], GoalUnifyY), GoalList = [GoalUnifyX, GoalUnifyY | UnifyArgsGoals] ), goal_info_init(Context, GoalInfo), conj_list_to_goal(GoalList, GoalInfo, Goal). :- pred generate_arg_unify_goals(uc_params::in, mer_type::in, prog_var::in, prog_var::in, int::in, list(constructor_arg_repn)::in, list(hlds_goal)::out, list(prog_var)::out, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_arg_unify_goals(_, _, _, _, _, [], [], [], [], !Info). generate_arg_unify_goals(UCParams, TermType, TermVarX, TermVarY, ArgNum, [CtorArgRepn | CtorArgRepns], Goals, VarsX, VarsY, !Info) :- may_we_start_packing_at_this_arg_unify(UCParams, CtorArgRepn, UnifyHow), GiveVarsTypes = UCParams ^ ucp_give_vars_types, ( UnifyHow = unify_unpacked, Type = CtorArgRepn ^ car_type, ModuleInfo = UCParams ^ ucp_module_info, IsDummy = is_type_a_dummy(ModuleInfo, Type), ( IsDummy = is_dummy_type, make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), generate_arg_unify_goals(UCParams, TermType, TermVarX, TermVarY, ArgNum + 1, CtorArgRepns, Goals, TailVarsX, TailVarsY, !Info) ; IsDummy = is_not_dummy_type, make_fresh_var_pair(GiveVarsTypes, "ArgX", "ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), % When unifying existentially typed arguments, the arguments % may have different types; in that case, rather than just % unifying them, which would be a type error, we call % `typed_unify', which is a builtin that first checks that % their types are equal and then unifies the values. Context = UCParams ^ ucp_context, ( if type_contains_existq_tvar(UCParams, Type) then build_simple_call(ModuleInfo, mercury_private_builtin_module, "typed_unify", [HeadVarX, HeadVarY], Context, HeadGoal) else create_pure_atomic_complicated_unification(HeadVarX, rhs_var(HeadVarY), Context, umc_explicit, [], HeadGoal) ), generate_arg_unify_goals(UCParams, TermType, TermVarX, TermVarY, ArgNum + 1, CtorArgRepns, TailGoals, TailVarsX, TailVarsY, !Info), Goals = [HeadGoal | TailGoals] ), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; UnifyHow = unify_packed(ArgsLocn, CellOffset), ( ArgsLocn = args_local, % If ArgsLocn = args_local, then all the arguments fit into % one word, and we can compare X and Y by casting both to ints % and comparing the ints. And we should have done just that above, % which means that execution should never get here. unexpected($pred, "args_local") ; ArgsLocn = args_remote(Ptag) ), info_set_packed_ops(used_some_packed_word_ops, !Info), Type = CtorArgRepn ^ car_type, Context = UCParams ^ ucp_context, expect_not(type_contains_existq_tvar(UCParams, Type), $pred, "sub-word-size argument of existential type"), make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), get_rest_of_word(UCParams, CellOffset, ArgNum, LeftOverArgNum, CtorArgRepns, LeftOverCtorArgRepns, RestOfWordVarsX, RestOfWordVarsY, !Info), ModuleInfo = UCParams ^ ucp_module_info, build_bulk_unify_foreign_proc(ModuleInfo, Ptag, TermType, TermVarX, TermVarY, ArgNum, CellOffset, Context, HeadGoals, !Info), generate_arg_unify_goals(UCParams, TermType, TermVarX, TermVarY, LeftOverArgNum, LeftOverCtorArgRepns, TailGoals, TailVarsX, TailVarsY, !Info), Goals = HeadGoals ++ TailGoals, VarsX = [HeadVarX | RestOfWordVarsX] ++ TailVarsX, VarsY = [HeadVarY | RestOfWordVarsY] ++ TailVarsY ). :- pred build_bulk_unify_foreign_proc(module_info::in, ptag::in, mer_type::in, prog_var::in, prog_var::in, int::in, cell_offset::in, prog_context::in, list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det. build_bulk_unify_foreign_proc(ModuleInfo, Ptag, TermType, TermVarX, TermVarY, ArgNum, CellOffset, Context, Goals, !Info) :- % Keep the predicates % build_bulk_unify_foreign_proc % select_and_build_signed_comparison_foreign_proc % select_and_build_bulk_comparison_foreign_proc % in sync where relevant. TermVarArgX = foreign_arg(TermVarX, yes(foreign_arg_name_mode("TermVarX", in_mode)), TermType, bp_native_if_possible), TermVarArgY = foreign_arg(TermVarY, yes(foreign_arg_name_mode("TermVarY", in_mode)), TermType, bp_native_if_possible), ForeignCode = " MR_Unsigned *cell_x; MR_Unsigned *cell_y; MR_Unsigned word_x; MR_Unsigned word_y; cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag); cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag); word_x = cell_x[CellOffsetVar]; word_y = cell_y[CellOffsetVar]; SUCCESS_INDICATOR = (word_x == word_y); ", PredName = "unify_remote_arg_words", make_ptag_and_cell_offset_args(ArgNum, Ptag, CellOffset, Context, WordsArgs, WordsGoals, !Info), ForeignArgs = [TermVarArgX, TermVarArgY] ++ WordsArgs, generate_call_foreign_proc(ModuleInfo, pf_predicate, mercury_private_builtin_module, PredName, [], ForeignArgs, [], instmap_delta_bind_no_var, only_mode, detism_semi, purity_pure, [], pure_proc_foreign_attributes, no, ForeignCode, Context, UnifyRemoteArgWordGoal), Goals = WordsGoals ++ [UnifyRemoteArgWordGoal]. :- func pure_proc_foreign_attributes = pragma_foreign_proc_attributes. pure_proc_foreign_attributes = !:Attrs :- !:Attrs = default_attributes(lang_c), set_may_call_mercury(proc_will_not_call_mercury, !Attrs), set_thread_safe(proc_thread_safe, !Attrs), set_purity(purity_pure, !Attrs), set_terminates(proc_terminates, !Attrs), set_may_throw_exception(proc_will_not_throw_exception, !Attrs), set_may_modify_trail(proc_will_not_modify_trail, !Attrs), set_may_call_mm_tabled(proc_will_not_call_mm_tabled, !Attrs), set_affects_liveness(proc_does_not_affect_liveness, !Attrs), set_allocates_memory(proc_does_not_allocate_memory, !Attrs), set_registers_roots(proc_does_not_register_roots, !Attrs). :- pred get_rest_of_word(uc_params::in, cell_offset::in, int::in, int::out, list(constructor_arg_repn)::in, list(constructor_arg_repn)::out, list(prog_var)::out, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. get_rest_of_word(_UCParams, _CellOffset, !ArgNum, [], [], [], [], !Info). get_rest_of_word(UCParams, CellOffset, !ArgNum, [CtorArgRepn | CtorArgRepns], LeftOverCtorArgRepns, VarsX, VarsY, !Info) :- ArgPosWidth = CtorArgRepn ^ car_pos_width, ( ( ArgPosWidth = apw_partial_shifted(_, ArgCellOffset, _, _, _, _) ; ArgPosWidth = apw_none_shifted(_, ArgCellOffset) ), Type = CtorArgRepn ^ car_type, expect_not(type_contains_existq_tvar(UCParams, Type), $pred, "sub-word-size argument of existential type"), expect(unify(CellOffset, ArgCellOffset), $pred, "apw_{partial,none}_shifted offset != CellOffset"), GiveVarsTypes = UCParams ^ ucp_give_vars_types, make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", !.ArgNum, Type, HeadVarX, HeadVarY, !Info), !:ArgNum = !.ArgNum + 1, get_rest_of_word(UCParams, CellOffset, !ArgNum, CtorArgRepns, LeftOverCtorArgRepns, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; ( ArgPosWidth = apw_full(_, _) ; ArgPosWidth = apw_double(_, _, _) ; ArgPosWidth = apw_none_nowhere ; ArgPosWidth = apw_partial_first(_, _, _, _, _, _) ), LeftOverCtorArgRepns = [CtorArgRepn | CtorArgRepns], VarsX = [], VarsY = [] ). :- pred type_contains_existq_tvar(uc_params::in, mer_type::in) is semidet. type_contains_existq_tvar(UCParams, Type) :- ExistQTVars = UCParams ^ ucp_existq_tvars, some [ExistQTVar] ( list.member(ExistQTVar, ExistQTVars), type_contains_var(Type, ExistQTVar) ). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% % % Generate clauses for compare predicates. % :- pred generate_compare_proc_body(spec_pred_defn_info::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body(SpecDefnInfo, Res, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), TypeBody = SpecDefnInfo ^ spdi_type_body, Context = SpecDefnInfo ^ spdi_context, ( if TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, subtype_of(SuperType), _, _, _) then % Compare subtype terms after casting to base type. TVarSet = SpecDefnInfo ^ spdi_tvarset, get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType), generate_compare_proc_body_eqv(Context, BaseType, Res, X, Y, Clause, !Info) else if % We used to special-case the type_ctors for which % is_type_ctor_a_builtin_dummy(TypeCtor) = is_builtin_dummy_type_ctor, % but both those types now have user-defined unify and compare preds. type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) then generate_compare_proc_body_user(Context, UserEqComp, Res, X, Y, Clause, !Info) else ( TypeBody = hlds_abstract_type(_), % There is no way we can generate unify, index or compare % predicates for actual abstract types. Having our ancestor % pass hlds_abstract_type here is a special in-band signal % that the type is actually a builtin type. ( if compiler_generated_rtti_for_builtins(ModuleInfo) then generate_compare_proc_body_builtin(SpecDefnInfo, Res, X, Y, Clause, !Info) else unexpected($pred, "trying to create compare proc for abstract type") ) ; TypeBody = hlds_eqv_type(EqvType), EqvIsDummy = is_type_a_dummy(ModuleInfo, EqvType), ( EqvIsDummy = is_dummy_type, % Treat this type as if it were a dummy type itself. generate_compare_proc_body_dummy(Context, Res, X, Y, Clause, !Info) ; EqvIsDummy = is_not_dummy_type, generate_compare_proc_body_eqv(Context, EqvType, Res, X, Y, Clause, !Info) ) ; TypeBody = hlds_foreign_type(_), % If no user defined equality predicate is given, % we treat foreign_types as if they were equivalent % to the builtin type c_pointer. generate_compare_proc_body_eqv(Context, c_pointer_type, Res, X, Y, Clause, !Info) ; TypeBody = hlds_solver_type(_), generate_compare_proc_body_solver(Context, Res, X, Y, Clause, !Info) ; TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, MaybeSuperType, _, MaybeRepn, _), expect(unify(MaybeSuperType, not_a_subtype), $pred, "MaybeSuperType != not_a_subtype"), ( MaybeRepn = no, unexpected($pred, "MaybeRepn = no") ; MaybeRepn = yes(Repn) ), DuTypeKind = Repn ^ dur_kind, ( ( DuTypeKind = du_type_kind_mercury_enum ; DuTypeKind = du_type_kind_foreign_enum(_) ), generate_compare_proc_body_enum(Context, Res, X, Y, Clause, !Info) ; DuTypeKind = du_type_kind_direct_dummy, generate_compare_proc_body_dummy(Context, Res, X, Y, Clause, !Info) ; DuTypeKind = du_type_kind_notag(_, ArgType, _), ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType), ( ArgIsDummy = is_dummy_type, % Treat this type as if it were a dummy type % itself. generate_compare_proc_body_dummy(Context, Res, X, Y, Clause, !Info) ; ArgIsDummy = is_not_dummy_type, CtorRepns = Repn ^ dur_ctor_repns, generate_compare_proc_body_du(SpecDefnInfo, CtorRepns, Res, X, Y, Clause, !Info) ) ; DuTypeKind = du_type_kind_general, CtorRepns = Repn ^ dur_ctor_repns, generate_compare_proc_body_du(SpecDefnInfo, CtorRepns, Res, X, Y, Clause, !Info) ) ) ). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_dummy(prog_context::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_dummy(Context, Res, X, Y, Clause, !Info) :- generate_return_equal(Res, Context, Goal), quantify_clause_body(all_modes, [Res, X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_user(prog_context::in, noncanonical::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_user(Context, NonCanonical, Res, X, Y, Clause, !Info) :- ( NonCanonical = noncanon_abstract(_), unexpected($pred, "trying to create compare proc for abstract noncanonical type") ; NonCanonical = noncanon_subtype, unexpected($pred, "trying to create compare proc for subtype") ; NonCanonical = noncanon_uni_only(_), % Just generate code that will call error/1. info_get_module_info(!.Info, ModuleInfo), ArgVars = [Res, X, Y], build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_compare_non_canonical_type", ArgVars, Context, Goal) ; ( NonCanonical = noncanon_uni_cmp(_, ComparePredName) ; NonCanonical = noncanon_cmp_only(ComparePredName) ), % Just generate a call to the specified predicate, which is the % user-defined comparison pred for this type. % (The pred_id and proc_id will be figured out % by type checking and mode analysis.) PredId = invalid_pred_id, ModeId = invalid_proc_id, ArgVars = [Res, X, Y], Call = plain_call(PredId, ModeId, ArgVars, not_builtin, no, ComparePredName), goal_info_init(Context, GoalInfo), Goal0 = hlds_goal(Call, GoalInfo), % XXX If the user-specified compare predicate always aborts, % we should avoid a pretest, since if it accidentally happens % to succeeed, it avoids the requested abort. maybe_wrap_with_pretest_equality(Context, X, Y, yes(Res), Goal0, Goal, !Info) ), quantify_clause_body(all_modes, ArgVars, Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_builtin(spec_pred_defn_info::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_builtin(SpecDefnInfo, Res, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, CtorCat = classify_type_ctor(ModuleInfo, TypeCtor), ArgVars = [Res, X, Y], % can_generate_special_pred_clauses_for_type ensures the unexpected % cases can never occur. ( CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int)), Name = "builtin_compare_int" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint)), Name = "builtin_compare_uint" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int8)), Name = "builtin_compare_int8" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint8)), Name = "builtin_compare_uint8" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int16)), Name = "builtin_compare_int16" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint16)), Name = "builtin_compare_uint16" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int32)), Name = "builtin_compare_int32" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint32)), Name = "builtin_compare_uint32" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int64)), Name = "builtin_compare_int64" ; CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint64)), Name = "builtin_compare_uint64" ; CtorCat = ctor_cat_builtin(cat_builtin_char), Name = "builtin_compare_character" ; CtorCat = ctor_cat_builtin(cat_builtin_string), Name = "builtin_compare_string" ; CtorCat = ctor_cat_builtin(cat_builtin_float), Name = "builtin_compare_float" ; CtorCat = ctor_cat_higher_order, Name = "builtin_compare_pred" ; ( CtorCat = ctor_cat_tuple ; CtorCat = ctor_cat_enum(_) ; CtorCat = ctor_cat_builtin_dummy ; CtorCat = ctor_cat_variable ; CtorCat = ctor_cat_void ; CtorCat = ctor_cat_system(_) ; CtorCat = ctor_cat_user(_) ), unexpected($pred, "bad ctor category") ), Context = SpecDefnInfo ^ spdi_context, build_simple_call(ModuleInfo, mercury_private_builtin_module, Name, ArgVars, Context, CompareGoal), quantify_clause_body(all_modes, ArgVars, CompareGoal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_eqv(prog_context::in, mer_type::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_eqv(Context, EqvType, Res, X, Y, Clause, !Info) :- % We should check whether EqvType is a type variable, an abstract type % or a concrete type. If it is type variable, then we should generate % the same code we generate now. If it is an abstract type, we should call % its comparison procedure directly; if it is a concrete type, we should % generate the body of its comparison procedure inline here. info_get_module_info(!.Info, ModuleInfo), make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 1, CastX, !Info), make_fresh_named_var_from_type(EqvType, "Cast_HeadVar", 2, CastY, !Info), generate_cast(equiv_type_cast, X, CastX, Context, CastXGoal), generate_cast(equiv_type_cast, Y, CastY, Context, CastYGoal), build_simple_call(ModuleInfo, mercury_public_builtin_module, "compare", [Res, CastX, CastY], Context, CompareGoal), goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal([CastXGoal, CastYGoal, CompareGoal], GoalInfo, Goal), quantify_clause_body(all_modes, [Res, X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_solver(prog_context::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_solver(Context, Res, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), ArgVars = [Res, X, Y], build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_compare_solver_type", ArgVars, Context, Goal), quantify_clause_body(all_modes, ArgVars, Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_enum(prog_context::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_enum(Context, Res, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), IntType = int_type, make_fresh_named_var_from_type(IntType, "Cast_HeadVar", 1, CastX, !Info), make_fresh_named_var_from_type(IntType, "Cast_HeadVar", 2, CastY, !Info), generate_cast(unsafe_type_cast, X, CastX, Context, CastXGoal), generate_cast(unsafe_type_cast, Y, CastY, Context, CastYGoal), build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_compare_int", [Res, CastX, CastY], Context, CompareGoal), goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal([CastXGoal, CastYGoal, CompareGoal], GoalInfo, Goal), quantify_clause_body(all_modes, [Res, X, Y], Goal, Context, Clause, !Info). %---------------------------------------------------------------------------% :- pred generate_compare_proc_body_du(spec_pred_defn_info::in, list(constructor_repn)::in, prog_var::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_du(SpecDefnInfo, CtorRepns, Res, X, Y, Clause, !Info) :- info_get_module_info(!.Info, ModuleInfo), module_info_get_globals(ModuleInfo, Globals), expect_not(unify(CtorRepns, []), $pred, "compare for type with no functors"), UCOptions = lookup_unify_compare_options(!.Info), Context = SpecDefnInfo ^ spdi_context, ( if UCOptions ^ uco_constants_as_ints = compare_constants_as_ints, UCOptions ^ uco_packed_unify_compare = allow_packed_unify_compare, % Can we compare two values of this type by casting both values % to unsigned and comparing the results? ( CtorRepns = [CtorRepnA], % If all the arguments of functor A are stored next to the ptag, % and if they are all comparable as unsigned, two conditions % that is_ctor_with_all_locally_packed_unsigned_args will test, % and if they are arranged earlier-args-in-more-significant-bits, % which is always guaranteed for packed arguments by % du_type_layout.m, then yes, cast-to-unsigned-and-compare % will work. is_ctor_with_all_locally_packed_unsigned_args(CtorRepnA, _) ; CtorRepns = [CtorRepnA, CtorRepnB], % If functor A comes before functor B, and % % - the value of a term whose functor is A *must* be all zeroes % - the value of a term whose functor is B *cannot* be all zeroes % % then comparing two terms, one bound to A and one bound to B, % by casting both to unsigned and comparing the results, will yield % the correct result. % % If A has arity zero, then there is only one possible term whose % functor is A, so cast-to-unsigned-and-compare works when % both terms are bound to A. And if B's arguments meet the % conditions laid out in the first switch arm above, then % cast-to-unsigned-and-compare also works when both terms % are bound to B. CtorRepnA = ctor_repn(_OrdinalA, _MaybeExistConstraintsA, _FunctorNameA, ConsTagA, _CtorArgRepnsA, ArityA, _CtxtA), ArityA = 0, ConsTagA = local_args_tag(LocalArgsTagInfoA), LocalArgsTagInfoA = local_args_not_only_functor(PtagA, LocalSecTagA), PtagA = ptag(0u8), LocalSecTagA = local_sectag(0u, _, _), is_ctor_with_all_locally_packed_unsigned_args(CtorRepnB, PtagBUint8), PtagBUint8 > 0u8 ) % If the type has three or more functors, then cast-to-unsigned-and- % compare will not work. % % If the third functor is a constant, then one of the constants % will have a nonzero local sectag value. If the arguments of the % non-constant functor happen to be all zeros, then this nonzero % local sectag can cause the unsigned comparison to report that % the constant is greater then the non-constant, even if the constant % comes earlier in the list of functors. And if this constant comes % later in the list of functors, then the unsigned comparison will % yield the wrong result if the value of some argument in the % nonconstant causes a bit to be set that is more significant % than the bit(s) set in the local sectag. So regardless of the % relative order of these two functors, correctness would not be % guaranteed. % % If the third functor is a non-constant, then comparisons between % terms bound to different non-constants should be decided by the % local sectags of the two terms regardless of the values of their % arguments, but the local sectag is stored in *less* significant bits % than the arguments. We cannot move the position of the local sectag % without incurring significant costs in RTTI complexity. then CastType = uint_type, info_new_var("CastX", CastType, CastX, !Info), info_new_var("CastY", CastType, CastY, !Info), generate_cast(unsafe_type_cast, X, CastX, Context, CastXGoal), generate_cast(unsafe_type_cast, Y, CastY, Context, CastYGoal), build_simple_call(ModuleInfo, mercury_public_builtin_module, "compare", [Res, CastX, CastY], Context, CompareGoal), GoalExpr = conj(plain_conj, [CastXGoal, CastYGoal, CompareGoal]), goal_info_init(Context, GoalInfo), Goal = hlds_goal(GoalExpr, GoalInfo) else globals.lookup_int_option(Globals, compare_specialization, CompareSpec), list.length(CtorRepns, NumCtors), ( if NumCtors =< CompareSpec then generate_compare_proc_body_du_quad(SpecDefnInfo, UCOptions, CtorRepns, Res, X, Y, Goal0, !Info) else generate_compare_proc_body_du_linear(SpecDefnInfo, UCOptions, CtorRepns, Res, X, Y, Goal0, !Info) ), maybe_wrap_with_pretest_equality(Context, X, Y, yes(Res), Goal0, Goal, !Info) ), HeadVars = [Res, X, Y], quantify_clause_body(all_modes, HeadVars, Goal, Context, Clause, !Info). :- pred is_ctor_with_all_locally_packed_unsigned_args(constructor_repn::in, uint8::out) is semidet. is_ctor_with_all_locally_packed_unsigned_args(CtorRepn, PtagUint8) :- CtorRepn = ctor_repn(_Ordinal, _MaybeExistConstraints, _FunctorName, ConsTag, CtorArgRepns, Arity, _Ctxt), Arity > 0, ConsTag = local_args_tag(LocalArgsTagInfo), ( LocalArgsTagInfo = local_args_only_functor, PtagUint8 = 0u8 ; LocalArgsTagInfo = local_args_not_only_functor(Ptag, LocalSecTag), Ptag = ptag(PtagUint8), LocalSecTag = local_sectag(0u, _, _) ), IsArgUnsignedComparable = ( pred(CtorArgRepn::in) is semidet :- ArgPosWidth = CtorArgRepn ^ car_pos_width, ( ( ArgPosWidth = apw_partial_first(_, _, _, _, _, Fill) ; ArgPosWidth = apw_partial_shifted(_, _, _, _, _, Fill) ), fill_bulk_comparability(Fill) = bulk_comparable_unsigned ; ArgPosWidth = apw_none_shifted(_, _) ) ), list.all_true(IsArgUnsignedComparable, CtorArgRepns). %---------------------% % generate_compare_proc_body_du_quad: for a du type, such as % % :- type foo % ---> f(a) % ; g(a, b, c) % ; h. % % the quadratic code we want to generate is % % compare(Res, X, Y) :- % ( % X = f(X1), % Y = f(Y1), % compare(R, X1, Y1) % ; % X = f(_), % Y = g(_, _, _), % R = (<) % ; % X = f(_), % Y = h, % R = (<) % ; % X = g(_, _, _), % Y = f(_), % R = (>) % ; % X = g(X1, X2, X3), % Y = g(Y1, Y2, Y3), % ( if compare(R1, X1, Y1), R1 \= (=) then % R = R1 % else if compare(R2, X2, Y2), R2 \= (=) then % R = R2 % else % compare(R, X3, Y3) % ) % ; % X = g(_, _, _), % Y = h, % R = (<) % ; % X = h, % Y = f(_), % R = (>) % ; % X = h, % Y = g(_, _, _), % R = (>) % ; % X = h, % Y = h, % R = (=) % ). % % Note that in the clauses handling two copies of the same constant, % we unify Y with the constant, not with X. This is required to get % switch_detection and det_analysis to recognize the determinism of the % predicate. % :- pred generate_compare_proc_body_du_quad(spec_pred_defn_info::in, uc_options::in, list(constructor_repn)::in, prog_var::in, prog_var::in, prog_var::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_du_quad(SpecDefnInfo, UCOptions, CtorRepns, R, X, Y, Goal, !Info) :- % XXX Consider returning switches, not disjunctions, both here % and everywhere else. generate_compare_du_quad_switch_on_x(SpecDefnInfo, UCOptions, CtorRepns, CtorRepns, R, X, Y, [], Cases, !Info), Context = SpecDefnInfo ^ spdi_context, goal_info_init(Context, GoalInfo), disj_list_to_goal(Cases, GoalInfo, Goal). :- pred generate_compare_du_quad_switch_on_x(spec_pred_defn_info::in, uc_options::in, list(constructor_repn)::in, list(constructor_repn)::in, prog_var::in, prog_var::in, prog_var::in, list(hlds_goal)::in, list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_du_quad_switch_on_x(_SpecDefnInfo, _UCOptions, [], _RightCtorRepns, _R, _X, _Y, !Cases, !Info). generate_compare_du_quad_switch_on_x(SpecDefnInfo, UCOptions, [LeftCtorRepn | LeftCtorRepns], RightCtorRepns, R, X, Y, !Cases, !Info) :- generate_compare_du_quad_switch_on_y(SpecDefnInfo, UCOptions, LeftCtorRepn, RightCtorRepns, ">", R, X, Y, !Cases, !Info), generate_compare_du_quad_switch_on_x(SpecDefnInfo, UCOptions, LeftCtorRepns, RightCtorRepns, R, X, Y, !Cases, !Info). :- pred generate_compare_du_quad_switch_on_y(spec_pred_defn_info::in, uc_options::in, constructor_repn::in, list(constructor_repn)::in, string::in, prog_var::in, prog_var::in, prog_var::in, list(hlds_goal)::in, list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_du_quad_switch_on_y(_SpecDefnInfo, _UCOptions, _LeftCtorRepn, [], _Cmp, _R, _X, _Y, !Cases, !Info). generate_compare_du_quad_switch_on_y(SpecDefnInfo, UCOptions, LeftCtorRepn, [RightCtorRepn | RightCtorRepns], Cmp0, R, X, Y, !Cases, !Info) :- ( if LeftCtorRepn = RightCtorRepn then generate_compare_case(SpecDefnInfo, UCOptions, quad, LeftCtorRepn, R, X, Y, Case, !Info), Cmp1 = "<" else generate_compare_du_quad_compare_asymmetric(SpecDefnInfo, LeftCtorRepn, RightCtorRepn, Cmp0, R, X, Y, Case, !Info), Cmp1 = Cmp0 ), generate_compare_du_quad_switch_on_y(SpecDefnInfo, UCOptions, LeftCtorRepn, RightCtorRepns, Cmp1, R, X, Y, [Case | !.Cases], !:Cases, !Info). :- pred generate_compare_du_quad_compare_asymmetric(spec_pred_defn_info::in, constructor_repn::in, constructor_repn::in, string::in, prog_var::in, prog_var::in, prog_var::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_du_quad_compare_asymmetric(SpecDefnInfo, CtorRepnA, CtorRepnB, CompareOp, R, X, Y, Case, !Info) :- CtorRepnA = ctor_repn(_OrdinalA, MaybeExistConstraintsA, FunctorNameA, _ConsTagA, ArgRepnsA, _ArityA, _CtxtA), CtorRepnB = ctor_repn(_OrdinalB, MaybeExistConstraintsB, FunctorNameB, _ConsTagB, ArgRepnsB, _ArityB, _CtxtB), list.length(ArgRepnsA, FunctorArityA), list.length(ArgRepnsB, FunctorArityB), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, FunctorConsIdA = cons(FunctorNameA, FunctorArityA, TypeCtor), FunctorConsIdB = cons(FunctorNameB, FunctorArityB, TypeCtor), make_fresh_vars_for_cons_args(ArgRepnsA, MaybeExistConstraintsA, VarsA, !Info), make_fresh_vars_for_cons_args(ArgRepnsB, MaybeExistConstraintsB, VarsB, !Info), RHSA = rhs_functor(FunctorConsIdA, is_not_exist_constr, VarsA), RHSB = rhs_functor(FunctorConsIdB, is_not_exist_constr, VarsB), Context = SpecDefnInfo ^ spdi_context, create_pure_atomic_complicated_unification(X, RHSA, Context, umc_explicit, [], GoalUnifyX), create_pure_atomic_complicated_unification(Y, RHSB, Context, umc_explicit, [], GoalUnifyY), make_const_construction(Context, R, compare_cons_id(CompareOp), ReturnResult), GoalList = [GoalUnifyX, GoalUnifyY, ReturnResult], goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal(GoalList, GoalInfo, Case). %---------------------% % generate_compare_proc_body_du_linear: for a du type, such as % % :- type foo % ---> f % ; g(a) % ; h(b, foo). % % the linear code we want to generate is % % compare(Res, X, Y) :- % __Index__(X, IndexX), % GoalIndexX % __Index__(Y, IndexY), % GoalIndexY % ( if IndexX < IndexY then % GoalCallLessThan % Res = (<) % GoalReturnLessThan % else if IndexX > IndexY then % GoalCallGreaterThan % Res = (>) % GoalReturnGreaterThan % else if % % The disjuncts of this disjunction are generated by % % the predicate generate_compare_du_linear_cases below. % ( % X = f % R = (=) % ; % X = g(X1), % Y = g(Y1), % compare(R, X1, Y1) % ; % X = h(X1, X2), % Y = h(Y1, Y2), % ( if compare(R1, X1, Y1), R1 \= (=) then % R = R1 % else % compare(R, X2, Y2) % ) % ) % then % Res = R % ReturnResultGoal % else % compare_error % AbortGoal % ). % % Note that disjuncts covering constants do not test Y, % since for constants, IndexX = IndexY implies X = Y. % :- pred generate_compare_proc_body_du_linear(spec_pred_defn_info::in, uc_options::in, list(constructor_repn)::in, prog_var::in, prog_var::in, prog_var::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_proc_body_du_linear(SpecDefnInfo, UCOptions, CtorRepns, Res, X, Y, Goal, !Info) :- IntType = int_type, info_new_var("IndexX", IntType, IndexX, !Info), info_new_var("IndexY", IntType, IndexY, !Info), info_new_var("CompareResult", comparison_result_type, R, !Info), goal_info_init(Context, GoalInfo), SpecDefnInfo = spec_pred_defn_info(_SpecialPredId, _ThisPredId, TVarSet, Type, TypeCtor, TypeBody, TypeStatus0, Context), info_get_module_info(!.Info, ModuleInfo0), add_special_pred_decl_defn(spec_pred_index, TVarSet, Type, TypeCtor, TypeBody, TypeStatus0, Context, ModuleInfo0, ModuleInfo), info_set_module_info(ModuleInfo, !Info), X_InstmapDelta = instmap_delta_bind_var(IndexX), build_spec_pred_call(TypeCtor, spec_pred_index, [X, IndexX], X_InstmapDelta, detism_det, Context, GoalIndexX, !Info), Y_InstmapDelta = instmap_delta_bind_var(IndexY), build_spec_pred_call(TypeCtor, spec_pred_index, [Y, IndexY], Y_InstmapDelta, detism_det, Context, GoalIndexY, !Info), build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_int_lt", [IndexX, IndexY], Context, GoalCallLessThan), build_simple_call(ModuleInfo, mercury_private_builtin_module, "builtin_int_gt", [IndexX, IndexY], Context, GoalCallGreaterThan), make_const_construction(Context, Res, compare_cons_id("<"), GoalReturnLessThan), make_const_construction(Context, Res, compare_cons_id(">"), GoalReturnGreaterThan), create_pure_atomic_complicated_unification(Res, rhs_var(R), Context, umc_explicit, [], ReturnResultGoal), generate_compare_du_linear_cases(SpecDefnInfo, UCOptions, CtorRepns, R, X, Y, Cases, !Info), CasesGoal = hlds_goal(disj(Cases), GoalInfo), build_simple_call(ModuleInfo, mercury_private_builtin_module, "compare_error", [], Context, AbortGoal), HandleEqualGoal = hlds_goal( if_then_else([], CasesGoal, ReturnResultGoal, AbortGoal), GoalInfo), HandleGreaterEqualGoal = hlds_goal( if_then_else([], GoalCallGreaterThan, GoalReturnGreaterThan, HandleEqualGoal), GoalInfo), HandleLessGreaterEqualGoal = hlds_goal( if_then_else([], GoalCallLessThan, GoalReturnLessThan, HandleGreaterEqualGoal), GoalInfo), Goal = hlds_goal( conj(plain_conj, [GoalIndexX, GoalIndexY, HandleLessGreaterEqualGoal]), GoalInfo). % generate_compare_du_linear_cases does a part of the job assigned to % generate_compare_proc_body_du_linear. Specifically, for a type such as % % :- type foo % ---> f % ; g(a) % ; h(b, foo). % % we generate % % ( % X = f, % GoalUnifyX % R = (=) % CompareArgsGoal % ; % X = g(X1), % Y = g(Y1), % compare(R, X1, Y1) % ; % X = h(X1, X2), % Y = h(Y1, Y2), % ( if compare(R1, X1, Y1), R1 \= (=) then % R = R1 % else % compare(R, X2, Y2) % ) % ) % :- pred generate_compare_du_linear_cases(spec_pred_defn_info::in, uc_options::in, list(constructor_repn)::in, prog_var::in, prog_var::in, prog_var::in, list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_du_linear_cases(_SpecDefnInfo, _UCOptions, [], _R, _X, _Y, [], !Info). generate_compare_du_linear_cases(SpecDefnInfo, UCOptions, [CtorRepn | CtorRepns], R, X, Y, [Case | Cases], !Info) :- generate_compare_case(SpecDefnInfo, UCOptions, linear, CtorRepn, R, X, Y, Case, !Info), generate_compare_du_linear_cases(SpecDefnInfo, UCOptions, CtorRepns, R, X, Y, Cases, !Info). %---------------------% :- type linear_or_quad ---> linear ; quad. :- pred generate_compare_case(spec_pred_defn_info::in, uc_options::in, linear_or_quad::in, constructor_repn::in, prog_var::in, prog_var::in, prog_var::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. generate_compare_case(SpecDefnInfo, UCOptions, LinearOrQuad, CtorRepn, R, X, Y, Case, !Info) :- CtorRepn = ctor_repn(_Ordinal, MaybeExistConstraints, FunctorName, ConsTag, ArgRepns, FunctorArity, _Ctxt), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor), Context = SpecDefnInfo ^ spdi_context, ( ArgRepns = [], RHS = rhs_functor(FunctorConsId, is_not_exist_constr, []), create_pure_atomic_complicated_unification(X, RHS, Context, umc_explicit, [], GoalUnifyX), generate_return_equal(R, Context, EqualGoal), ( LinearOrQuad = linear, % The disjunct we are generating is executed only if the index % values of X and Y are the same, so if X is bound to a constant, % Y must also be bound to that same constant. GoalList = [GoalUnifyX, EqualGoal] ; LinearOrQuad = quad, create_pure_atomic_complicated_unification(Y, RHS, Context, umc_explicit, [], GoalUnifyY), GoalList = [GoalUnifyX, GoalUnifyY, EqualGoal] ) ; ArgRepns = [_ | _], compute_exist_constraint_implications(MaybeExistConstraints, ExistQTVars, GiveVarsTypes), MaybePackableArgsLocn = compute_maybe_packable_args_locn(ConsTag), info_get_module_info(!.Info, ModuleInfo), UCParams = uc_params(ModuleInfo, Context, ExistQTVars, MaybePackableArgsLocn, GiveVarsTypes, UCOptions ^ uco_constants_as_ints, UCOptions ^ uco_packed_unify_compare), info_get_var_table(!.Info, VarTable0), lookup_var_type(VarTable0, X, TermType), generate_arg_compare_goals(UCParams, TermType, X, Y, R, all_args_in_word_so_far, 1, ArgRepns, CompareArgsGoal, VarsX, VarsY, !Info), RHSX = rhs_functor(FunctorConsId, is_not_exist_constr, VarsX), RHSY = rhs_functor(FunctorConsId, is_not_exist_constr, VarsY), create_pure_atomic_complicated_unification(X, RHSX, Context, umc_explicit, [], GoalUnifyX), create_pure_atomic_complicated_unification(Y, RHSY, Context, umc_explicit, [], GoalUnifyY), GoalList = [GoalUnifyX, GoalUnifyY, CompareArgsGoal] ), goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal(GoalList, GoalInfo, Case). %---------------------% % generate_arg_compare_goals: for a constructor such as % % h(list(int), foo, string) % % none of whose arguments are special in any way, we want to generate % code such as: % % ( if % compare(SubResult1, X1, Y1), % SubResult1 \= (=) % then % Result = SubResult1 % else if % compare(SubResult2, X2, Y2), % SubResult2 \= (=) % then % Result = SubResult2 % else % compare(Result, X3, Y3) % ) % % The idea is that for each non-last argument, we compare the % corresponding arguments, and then % % - if they are not equal, we return the result of their comparison, while % - if they *are* equal, then we proceed to compare the later arguments. % % For the last argument, we always return the result of the argument % comparison. % % This results in the if-then-else chain above. This chain is built by % prepare_for_conjoining_arg_comparisons and conjoin_arg_comparisons below. % % However, we handle some arguments differently. % % - Arguments whose type is a dummy type don't need to be compared % at all. Since a dummy type consists of only one value, two values % of the same dummy type are always equal. % % - Any consecutive sequence of sub-word-sized arguments of unsigned types % that are packed together into one word can be compared by a single % unsigned compare operation of all their bits, because the arg packing % algorithm puts the earlier arguments into higher value bit positions % specifically to make this possible. Since this bulk comparison % cannot be expressed in Mercury, the code we generate for it is in C, % wrapped up in a foreign_proc. (We enable argument packing only % when targeting C.) % % - We also generate C code inside a foreign_proc for any sub-word-sized % argument of a signed type (int8, int16 or int32) that is packed % together with other sub-word-sized arguments. We *could* simply let % the initial deconstruction of the two terms being compared % pick up the values of these arguments, and compare them by calling % builtin.compare, but that approach has a lot more overhead than % the simple, direct code in the foreign_proc we generate. % :- pred generate_arg_compare_goals(uc_params::in, mer_type::in, prog_var::in, prog_var::in, prog_var::in, maybe_all_args_in_word_so_far::in, int::in, list(constructor_arg_repn)::in, hlds_goal::out, list(prog_var)::out, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. generate_arg_compare_goals(UCParams, _, _, _, ResultVar, _, _, [], Goal, [], [], !Info) :- generate_return_equal(ResultVar, UCParams ^ ucp_context, Goal). generate_arg_compare_goals(UCParams, TermType, TermVarX, TermVarY, ResultVar, !.MaybeAllArgs, ArgNum, [CtorArgRepn | CtorArgRepns], Goal, VarsX, VarsY, !Info) :- GiveVarsTypes = UCParams ^ ucp_give_vars_types, ModuleInfo = UCParams ^ ucp_module_info, Type = CtorArgRepn ^ car_type, IsDummy = is_type_a_dummy(ModuleInfo, Type), ( IsDummy = is_dummy_type, % X and Y contain dummy values, so there is nothing to compare. make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), generate_arg_compare_goals(UCParams, TermType, TermVarX, TermVarY, ResultVar, !.MaybeAllArgs, ArgNum + 1, CtorArgRepns, Goal, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; IsDummy = is_not_dummy_type, Context = UCParams ^ ucp_context, may_we_start_packing_at_this_arg_compare(UCParams, CtorArgRepn, CompareHow, !MaybeAllArgs), ( CompareHow = compare_noop, make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), generate_arg_compare_goals(UCParams, TermType, TermVarX, TermVarY, ResultVar, !.MaybeAllArgs, ArgNum + 1, CtorArgRepns, Goal, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; CompareHow = compare_unpacked, make_fresh_var_pair(GiveVarsTypes, "ArgX", "ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), % When comparing existentially typed arguments, the arguments % may have different types; in that case, rather than just % comparing them, which would be a type error, we call % `typed_compare', which is a builtin that first compares % their types, and compares their values only if the types match. ( if type_contains_existq_tvar(UCParams, Type) then ComparePred = "typed_compare", ComparePredModule = mercury_private_builtin_module else ComparePred = "compare", ComparePredModule = mercury_public_builtin_module ), prepare_for_conjoining_arg_comparisons(CtorArgRepns, ArgNum, ResultVar, CurCompareResultVar, ConjoinKind, !Info), build_simple_call(ModuleInfo, ComparePredModule, ComparePred, [CurCompareResultVar, HeadVarX, HeadVarY], Context, SubCompareGoal), conjoin_arg_comparisons(UCParams, ConjoinKind, TermType, TermVarX, TermVarY, ResultVar, not_all_args_in_word_so_far, ArgNum + 1, SubCompareGoal, Goal, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; CompareHow = compare_subword_signed(ArgsLocn, CellOffset, Shift, SignedIntSize), make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), prepare_for_conjoining_arg_comparisons(CtorArgRepns, ArgNum, ResultVar, CurCompareResultVar, ConjoinKind, !Info), select_and_build_signed_comparison_foreign_proc(ModuleInfo, ArgsLocn, TermType, TermVarX, TermVarY, CurCompareResultVar, ArgNum, CellOffset, Shift, SignedIntSize, Context, SubCompareGoal, !Info), conjoin_arg_comparisons(UCParams, ConjoinKind, TermType, TermVarX, TermVarY, ResultVar, not_all_args_in_word_so_far, ArgNum + 1, SubCompareGoal, Goal, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; CompareHow = compare_packed(ArgsLocn, CellOffset, Shift0, NumBits0), expect_not(type_contains_existq_tvar(UCParams, Type), $pred, "sub-word-size argument of existential type"), make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", ArgNum, Type, HeadVarX, HeadVarY, !Info), get_bulk_comparable_packed_args(UCParams, CellOffset, ArgNum, LeftOverArgNum, Shift0, Shift, NumBits0, NumBits, CtorArgRepns, LeftOverCtorArgRepns, !MaybeAllArgs, TailBulkVarsX, TailBulkVarsY, !Info), prepare_for_conjoining_arg_comparisons(LeftOverCtorArgRepns, ArgNum, ResultVar, CurCompareResultVar, ConjoinKind, !Info), select_and_build_bulk_comparison_foreign_proc(ModuleInfo, ArgsLocn, TermType, TermVarX, TermVarY, CurCompareResultVar, !.MaybeAllArgs, ArgNum, CellOffset, Shift, NumBits, Context, SubCompareGoal, !Info), conjoin_arg_comparisons(UCParams, ConjoinKind, TermType, TermVarX, TermVarY, ResultVar, !.MaybeAllArgs, LeftOverArgNum, SubCompareGoal, Goal, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailBulkVarsX] ++ TailVarsX, VarsY = [HeadVarY | TailBulkVarsY] ++ TailVarsY ) ). :- type compare_conjoin_kind ---> no_more_comparisons ; more_comparisons( constructor_arg_repn, list(constructor_arg_repn), prog_var ). :- pred prepare_for_conjoining_arg_comparisons(list(constructor_arg_repn)::in, int::in, prog_var::in, prog_var::out, compare_conjoin_kind::out, unify_proc_info::in, unify_proc_info::out) is det. prepare_for_conjoining_arg_comparisons(CtorArgRepns, ArgNum, ResultVar, CurCompareResultVar, ConjoinKind, !Info) :- ( CtorArgRepns = [], CurCompareResultVar = ResultVar, ConjoinKind = no_more_comparisons ; CtorArgRepns = [HeadCtorArgRepn | TailCtorArgRepns], make_fresh_var(give_vars_types, "SubResult", ArgNum, comparison_result_type, CurCompareResultVar, !Info), ConjoinKind = more_comparisons(HeadCtorArgRepn, TailCtorArgRepns, CurCompareResultVar) ). :- pred conjoin_arg_comparisons(uc_params::in, compare_conjoin_kind::in, mer_type::in, prog_var::in, prog_var::in, prog_var::in, maybe_all_args_in_word_so_far::in, int::in, hlds_goal::in, hlds_goal::out, list(prog_var)::out, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. conjoin_arg_comparisons(UCParams, ConjoinKind, TermType, TermVarX, TermVarY, ResultVar, MaybeAllArgs, NextArgNum, SubCompareGoal, Goal, TailVarsX, TailVarsY, !Info) :- ( ConjoinKind = no_more_comparisons, Goal = SubCompareGoal, TailVarsX = [], TailVarsY = [] ; ConjoinKind = more_comparisons(HeadCtorArgRepn, TailCtorArgRepns, SubResultVar), Context = UCParams ^ ucp_context, goal_info_init(Context, GoalInfo), make_const_construction(Context, SubResultVar, compare_cons_id("="), CheckEqualGoal), CheckNotEqualGoal = hlds_goal(negation(CheckEqualGoal), GoalInfo), SubResultRHS = rhs_var(SubResultVar), create_pure_atomic_complicated_unification(ResultVar, SubResultRHS, Context, umc_explicit, [], ReturnSubResultGoal), CondGoalExpr = conj(plain_conj, [SubCompareGoal, CheckNotEqualGoal]), CondGoal = hlds_goal(CondGoalExpr, GoalInfo), generate_arg_compare_goals(UCParams, TermType, TermVarX, TermVarY, ResultVar, MaybeAllArgs, NextArgNum, [HeadCtorArgRepn | TailCtorArgRepns], ElseGoal, TailVarsX, TailVarsY, !Info), GoalExpr = if_then_else([], CondGoal, ReturnSubResultGoal, ElseGoal), Goal = hlds_goal(GoalExpr, GoalInfo) ). %---------------------% :- pred select_and_build_signed_comparison_foreign_proc(module_info::in, args_locn::in, mer_type::in, prog_var::in, prog_var::in, prog_var::in, int::in, cell_offset::in, arg_shift::in, string::in, prog_context::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. select_and_build_signed_comparison_foreign_proc(ModuleInfo, ArgsLocn, TermType, TermVarX, TermVarY, CompareResultVar, ArgNum, CellOffset, Shift, SizeStr, Context, CompareConjGoal, !Info) :- % Keep the predicates % build_bulk_unify_foreign_proc % select_and_build_signed_comparison_foreign_proc % select_and_build_bulk_comparison_foreign_proc % in sync where relevant. TermVarXForeignArg = foreign_arg(TermVarX, yes(foreign_arg_name_mode("TermVarX", in_mode)), TermType, bp_native_if_possible), TermVarYForeignArg = foreign_arg(TermVarY, yes(foreign_arg_name_mode("TermVarY", in_mode)), TermType, bp_native_if_possible), CompareResultForeignArg = foreign_arg(CompareResultVar, yes(foreign_arg_name_mode("ResultVar", out_mode)), comparison_result_type, bp_native_if_possible), % Keep the Remote versions in sync with generate_arg_unify_goals. LocalWordsDecl = " MR_Unsigned word_x; MR_Unsigned word_y; ", LocalWordsCode = " word_x = (MR_Unsigned) TermVarX; word_y = (MR_Unsigned) TermVarY; ", RemoteWordsDecl = " MR_Unsigned *cell_x; MR_Unsigned *cell_y; MR_Unsigned word_x; MR_Unsigned word_y; ", RemoteWordsCode = " cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag); cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag); word_x = cell_x[CellOffsetVar]; word_y = cell_y[CellOffsetVar]; ", ValuesDecl = string.format(" MR_Unsigned mask; int%s_t value_x; int%s_t value_y; ", [s(SizeStr), s(SizeStr)]), ValuesCode = string.format(" mask = (MR_Unsigned) ((UINT64_C(1) << %s) - 1); value_x = (int%s_t) (word_x >> ShiftVar) & mask; value_y = (int%s_t) (word_y >> ShiftVar) & mask; ", [s(SizeStr), s(SizeStr), s(SizeStr)]), CompareValuesCode = " if (value_x < value_y) { ResultVar = MR_COMPARE_LESS; } else if (value_x > value_y) { ResultVar = MR_COMPARE_GREATER; } else { ResultVar = MR_COMPARE_EQUAL; } ", Shift = arg_shift(ShiftInt), make_fresh_int_var_and_arg(Context, "ShiftVar", ArgNum, ShiftInt, ShiftForeignArg, MakeShiftGoal, !Info), ( ArgsLocn = args_local, ComparePredName = string.format("compare_local_int%s_bitfields", [s(SizeStr)]), MaybeWordsArgs = [], MaybeWordsGoals = [], WordsDecl = LocalWordsDecl, WordsCode = LocalWordsCode ; ArgsLocn = args_remote(Ptag), ComparePredName = string.format("compare_remote_int%s_bitfields", [s(SizeStr)]), make_ptag_and_cell_offset_args(ArgNum, Ptag, CellOffset, Context, MaybeWordsArgs, MaybeWordsGoals, !Info), WordsDecl = RemoteWordsDecl, WordsCode = RemoteWordsCode ), ForeignArgs = [TermVarXForeignArg, TermVarYForeignArg] ++ MaybeWordsArgs ++ [ShiftForeignArg, CompareResultForeignArg], ForeignCode = WordsDecl ++ ValuesDecl ++ WordsCode ++ ValuesCode ++ CompareValuesCode, generate_call_foreign_proc(ModuleInfo, pf_predicate, mercury_private_builtin_module, ComparePredName, [], ForeignArgs, [], instmap_delta_bind_var(CompareResultVar), only_mode, detism_semi, purity_pure, [], pure_proc_foreign_attributes, no, ForeignCode, Context, CompareGoal), CompareConjGoalExpr = conj(plain_conj, MaybeWordsGoals ++ [MakeShiftGoal, CompareGoal]), goal_info_init(Context, ContextGoalInfo), CompareConjGoal = hlds_goal(CompareConjGoalExpr, ContextGoalInfo). :- pred select_and_build_bulk_comparison_foreign_proc(module_info::in, args_locn::in, mer_type::in, prog_var::in, prog_var::in, prog_var::in, maybe_all_args_in_word_so_far::in, int::in, cell_offset::in, arg_shift::in, arg_num_bits::in, prog_context::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. select_and_build_bulk_comparison_foreign_proc(ModuleInfo, ArgsLocn, TermType, TermVarX, TermVarY, CompareResultVar, MaybeAllArgs, ArgNum, CellOffset, Shift, NumBits, Context, CompareConjGoal, !Info) :- % Keep the predicates % build_bulk_unify_foreign_proc % select_and_build_signed_comparison_foreign_proc % select_and_build_bulk_comparison_foreign_proc % in sync where relevant. TermVarXForeignArg = foreign_arg(TermVarX, yes(foreign_arg_name_mode("TermVarX", in_mode)), TermType, bp_native_if_possible), TermVarYForeignArg = foreign_arg(TermVarY, yes(foreign_arg_name_mode("TermVarY", in_mode)), TermType, bp_native_if_possible), CompareResultForeignArg = foreign_arg(CompareResultVar, yes(foreign_arg_name_mode("ResultVar", out_mode)), comparison_result_type, bp_native_if_possible), LocalWordsDecl = " MR_Unsigned word_x; MR_Unsigned word_y; ", LocalWordsCode = " word_x = (MR_Unsigned) TermVarX; word_y = (MR_Unsigned) TermVarY; ", RemoteWordsDecl = " MR_Unsigned *cell_x; MR_Unsigned *cell_y; MR_Unsigned word_x; MR_Unsigned word_y; ", RemoteWordsCode = " cell_x = (MR_Unsigned *) (((MR_Unsigned) TermVarX) - (MR_Unsigned) Ptag); cell_y = (MR_Unsigned *) (((MR_Unsigned) TermVarY) - (MR_Unsigned) Ptag); word_x = cell_x[CellOffsetVar]; word_y = cell_y[CellOffsetVar]; ", ValuesFromWordsDecl = " MR_Unsigned value_x; MR_Unsigned value_y; ", ValuesFromWordsCode = " value_x = word_x; value_y = word_y; ", ValuesFromShiftMaskDecl = " MR_Unsigned mask; MR_Unsigned value_x; MR_Unsigned value_y; ", ValuesFromShiftMaskCode = " mask = (MR_Unsigned) ((UINT64_C(1) << NumBitsVar) - 1); value_x = (word_x >> ShiftVar) & mask; value_y = (word_y >> ShiftVar) & mask; ", CompareValuesCode = " if (value_x < value_y) { ResultVar = MR_COMPARE_LESS; } else if (value_x > value_y) { ResultVar = MR_COMPARE_GREATER; } else { ResultVar = MR_COMPARE_EQUAL; } ", ( MaybeAllArgs = all_args_in_word_so_far, ComparePredNameSuffix = "words", ValuesDecl = ValuesFromWordsDecl, ValuesCode = ValuesFromWordsCode, MaybeShiftMaskArgs = [], MaybeShiftMaskGoals = [] ; MaybeAllArgs = not_all_args_in_word_so_far, ComparePredNameSuffix = "bitfields", Shift = arg_shift(ShiftInt), make_fresh_int_var_and_arg(Context, "ShiftVar", ArgNum, ShiftInt, ShiftForeignArg, MakeShiftGoal, !Info), NumBits = arg_num_bits(NumBitsInt), make_fresh_int_var_and_arg(Context, "NumBitsVar", ArgNum, NumBitsInt, NumBitsForeignArg, MakeNumBitsGoal, !Info), ValuesDecl = ValuesFromShiftMaskDecl, ValuesCode = ValuesFromShiftMaskCode, MaybeShiftMaskArgs = [ShiftForeignArg, NumBitsForeignArg], MaybeShiftMaskGoals = [MakeShiftGoal, MakeNumBitsGoal] ), ( ArgsLocn = args_local, ComparePredName = "compare_local_uint_" ++ ComparePredNameSuffix, MaybeWordsArgs = [], MaybeWordsGoals = [], WordsDecl = LocalWordsDecl, WordsCode = LocalWordsCode ; ArgsLocn = args_remote(Ptag), ComparePredName = "compare_remote_uint_" ++ ComparePredNameSuffix, make_ptag_and_cell_offset_args(ArgNum, Ptag, CellOffset, Context, MaybeWordsArgs, MaybeWordsGoals, !Info), WordsDecl = RemoteWordsDecl, WordsCode = RemoteWordsCode ), ForeignArgs = [TermVarXForeignArg, TermVarYForeignArg] ++ MaybeWordsArgs ++ MaybeShiftMaskArgs ++ [CompareResultForeignArg], ForeignCode = WordsDecl ++ ValuesDecl ++ WordsCode ++ ValuesCode ++ CompareValuesCode, generate_call_foreign_proc(ModuleInfo, pf_predicate, mercury_private_builtin_module, ComparePredName, [], ForeignArgs, [], instmap_delta_bind_var(CompareResultVar), only_mode, detism_semi, purity_pure, [], pure_proc_foreign_attributes, no, ForeignCode, Context, CompareGoal), CompareConjGoalExpr = conj(plain_conj, MaybeWordsGoals ++ MaybeShiftMaskGoals ++ [CompareGoal]), goal_info_init(Context, ContextGoalInfo), CompareConjGoal = hlds_goal(CompareConjGoalExpr, ContextGoalInfo). :- pred get_bulk_comparable_packed_args(uc_params::in, cell_offset::in, int::in, int::out, arg_shift::in, arg_shift::out, arg_num_bits::in, arg_num_bits::out, list(constructor_arg_repn)::in, list(constructor_arg_repn)::out, maybe_all_args_in_word_so_far::in, maybe_all_args_in_word_so_far::out, list(prog_var)::out, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. get_bulk_comparable_packed_args(_UCParams, _CellOffset, !ArgNum, !Shift, !NumBits, [], [], !MaybeAllArgs, [], [], !Info). get_bulk_comparable_packed_args(UCParams, CellOffset, !ArgNum, !Shift, !NumBits, [CtorArgRepn | CtorArgRepns], LeftOverCtorArgRepns, !MaybeAllArgs, VarsX, VarsY, !Info) :- ArgPosWidth = CtorArgRepn ^ car_pos_width, ( ( ArgPosWidth = apw_partial_shifted(_, _, _, _, _, Fill), BulkComparability = fill_bulk_comparability(Fill) ; ArgPosWidth = apw_none_shifted(_, _), BulkComparability = bulk_comparable_unsigned ), ( BulkComparability = bulk_comparable_unsigned, Type = CtorArgRepn ^ car_type, expect_not(type_contains_existq_tvar(UCParams, Type), $pred, "sub-word-size argument of existential type"), ( ArgPosWidth = apw_partial_shifted(_, ArgCellOffset, ArgShift, ArgNumBits, _, _), !.Shift = arg_shift(ShiftInt0), !.NumBits = arg_num_bits(NumBitsInt0), ArgShift = arg_shift(ArgShiftInt), ArgNumBits = arg_num_bits(ArgNumBitsInt), ShiftInt = ArgShiftInt, NumBitsInt = NumBitsInt0 + ArgNumBitsInt, expect(unify(ArgShiftInt + ArgNumBitsInt, ShiftInt0), $pred, "packed arg does not immediately follow previous"), !:Shift = arg_shift(ShiftInt), !:NumBits = arg_num_bits(NumBitsInt) ; ArgPosWidth = apw_none_shifted(_, ArgCellOffset) % Leave !Shift and !NumBits unchanged. ), expect(unify(CellOffset, ArgCellOffset), $pred, "apw_{partial,none}_shifted offset != CellOffset"), GiveVarsTypes = UCParams ^ ucp_give_vars_types, make_fresh_var_pair(GiveVarsTypes, "_ArgX", "_ArgY", !.ArgNum, Type, HeadVarX, HeadVarY, !Info), !:ArgNum = !.ArgNum + 1, get_bulk_comparable_packed_args(UCParams, CellOffset, !ArgNum, !Shift, !NumBits, CtorArgRepns, LeftOverCtorArgRepns, !MaybeAllArgs, TailVarsX, TailVarsY, !Info), VarsX = [HeadVarX | TailVarsX], VarsY = [HeadVarY | TailVarsY] ; BulkComparability = not_bulk_comparable(_SignedIntSize), LeftOverCtorArgRepns = [CtorArgRepn | CtorArgRepns], !:MaybeAllArgs = not_all_args_in_word_so_far, VarsX = [], VarsY = [] ) ; ( ArgPosWidth = apw_full(_, _) ; ArgPosWidth = apw_double(_, _, _) ; ArgPosWidth = apw_none_nowhere ; ArgPosWidth = apw_partial_first(_, _, _, _, _, _) ), LeftOverCtorArgRepns = [CtorArgRepn | CtorArgRepns], % This arg is in the next word, so if we started with % !.MaybeAllArgs = all_args_in_word_so_far, then return the same. VarsX = [], VarsY = [] ). :- type bulk_comparability ---> not_bulk_comparable(string) % Should be "8", "16" or "32". ; bulk_comparable_unsigned. :- func fill_bulk_comparability(fill_kind) = bulk_comparability. fill_bulk_comparability(Fill) = BulkComparability :- ( ( Fill = fill_enum ; Fill = fill_uint8 ; Fill = fill_uint16 ; Fill = fill_uint32 ; Fill = fill_char21 ), BulkComparability = bulk_comparable_unsigned ; ( Fill = fill_int8, SizeStr = "8" ; Fill = fill_int16, SizeStr = "16" ; Fill = fill_int32, SizeStr = "32" ), BulkComparability = not_bulk_comparable(SizeStr) ). %---------------------% :- type unify_how ---> unify_unpacked ; unify_packed(args_locn, cell_offset). :- pred may_we_start_packing_at_this_arg_unify(uc_params::in, constructor_arg_repn::in, unify_how::out) is det. may_we_start_packing_at_this_arg_unify(UCParams, CtorArgRepn, UnifyHow) :- AllowPackedUnifyCompare = UCParams ^ ucp_packed_unify_compare, ( AllowPackedUnifyCompare = do_not_allow_packed_unify_compare, UnifyHow = unify_unpacked ; AllowPackedUnifyCompare = allow_packed_unify_compare, MaybePackableArgsLocn = UCParams ^ ucp_maybe_packable_args, ( MaybePackableArgsLocn = unpackable_args, UnifyHow = unify_unpacked ; MaybePackableArgsLocn = packable_args(ArgsLocn), ArgPosWidth = CtorArgRepn ^ car_pos_width, ( ( ArgPosWidth = apw_full(_, _) ; ArgPosWidth = apw_double(_, _, _) ; ArgPosWidth = apw_none_nowhere ), UnifyHow = unify_unpacked ; ( ArgPosWidth = apw_partial_first(_, CellOffset, _, _, _, _) ; ArgPosWidth = apw_partial_shifted(_, CellOffset, _, _, _, _) ), % The first arg in a packed word can be apw_partial_shifted % in words whose first packed entity is a remote sectag. UnifyHow = unify_packed(ArgsLocn, CellOffset) ; ArgPosWidth = apw_none_shifted(_, CellOffset), % For unifications, either we unify all the arguments % that are packed into the same word together, or we unify % them all separately, depending on AllowPackedUnifyCompare. % The only situation in which we can start packing here % is when a function symbol's representation includes % a sub-word-sized sectag, and the first argument is % of a dummy type. UnifyHow = unify_packed(ArgsLocn, CellOffset) ) ) ). %---------------------% :- type compare_how ---> compare_unpacked ; compare_noop ; compare_subword_signed(args_locn, cell_offset, arg_shift, string) % The string should give the size: it should be "8", "16" or "32". ; compare_packed(args_locn, cell_offset, arg_shift, arg_num_bits). :- pred may_we_start_packing_at_this_arg_compare(uc_params::in, constructor_arg_repn::in, compare_how::out, maybe_all_args_in_word_so_far::in, maybe_all_args_in_word_so_far::out) is det. may_we_start_packing_at_this_arg_compare(UCParams, CtorArgRepn, CompareHow, !MaybeAllArgs) :- AllowPackedUnifyCompare = UCParams ^ ucp_packed_unify_compare, ( AllowPackedUnifyCompare = do_not_allow_packed_unify_compare, CompareHow = compare_unpacked % The value of !:MaybeAllArgs won't be consulted. ; AllowPackedUnifyCompare = allow_packed_unify_compare, MaybePackableArgsLocn = UCParams ^ ucp_maybe_packable_args, ( MaybePackableArgsLocn = unpackable_args, CompareHow = compare_unpacked ; MaybePackableArgsLocn = packable_args(ArgsLocn), ArgPosWidth = CtorArgRepn ^ car_pos_width, ( ( ArgPosWidth = apw_full(_, _) ; ArgPosWidth = apw_double(_, _, _) ; ArgPosWidth = apw_none_nowhere ), CompareHow = compare_unpacked, !:MaybeAllArgs = all_args_in_word_so_far ; ( ArgPosWidth = apw_partial_first(_, CellOffset, Shift, NumBits, _, Fill), !:MaybeAllArgs = all_args_in_word_so_far ; ArgPosWidth = apw_partial_shifted(_, CellOffset, Shift, NumBits, _, Fill) % Leave !MaybeAllArgs as it was. ), % The first arg in a packed word can be apw_partial_shifted % in words whose first packed entity is a remote sectag. BulkComparability = fill_bulk_comparability(Fill), ( BulkComparability = bulk_comparable_unsigned, CompareHow = compare_packed(ArgsLocn, CellOffset, Shift, NumBits) ; BulkComparability = not_bulk_comparable(SignedIntSize), CompareHow = compare_subword_signed(ArgsLocn, CellOffset, Shift, SignedIntSize) ) ; ArgPosWidth = apw_none_shifted(_, _), % After e.g. a remote sectag or an int8 argument, the next % packed argument to compare may be apw_none_shifted. CompareHow = compare_noop % Leave !MaybeAllArgs as it was. ) ) ). %---------------------% :- pred generate_return_equal(prog_var::in, prog_context::in, hlds_goal::out) is det. generate_return_equal(ResultVar, Context, Goal) :- make_const_construction(Context, ResultVar, compare_cons_id("="), Goal). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% % % Generate clauses for index predicates. % :- pred generate_index_proc_body(spec_pred_defn_info::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_index_proc_body(SpecDefnInfo, X, Index, Clause, !Info) :- % The only kind of type for which generate_compare_proc_body ends up % creating an index predicate is one which is % % - does not have a user-defined equality or comparison predicate, % - is a general du type, i.e. not dummy, not foreign, not enum, not notag. % TypeBody = SpecDefnInfo ^ spdi_type_body, ( TypeBody = hlds_abstract_type(_), unexpected($pred, "trying to create index proc for abstract type") ; TypeBody = hlds_eqv_type(_Type), unexpected($pred, "trying to create index proc for eqv type") ; TypeBody = hlds_foreign_type(_), unexpected($pred, "trying to create index proc for a foreign type") ; TypeBody = hlds_solver_type(_), unexpected($pred, "trying to create index proc for a solver type") ; TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, _, _, MaybeRepn, _), ( MaybeRepn = no, unexpected($pred, "MaybeRepn = no") ; MaybeRepn = yes(Repn) ), DuTypeKind = Repn ^ dur_kind, ( DuTypeKind = du_type_kind_mercury_enum, unexpected($pred, "trying to create index proc for enum type") ; DuTypeKind = du_type_kind_foreign_enum(_), unexpected($pred, "trying to create index proc for foreign enum type") ; DuTypeKind = du_type_kind_direct_dummy, unexpected($pred, "trying to create index proc for dummy type") ; DuTypeKind = du_type_kind_notag(_, _, _), unexpected($pred, "trying to create index proc for notag type") ; DuTypeKind = du_type_kind_general, CtorRepns = Repn ^ dur_ctor_repns, generate_index_proc_body_du(SpecDefnInfo, CtorRepns, X, Index, Clause, !Info) ) ). %---------------------------------------------------------------------------% % generate_index_proc_body_du: for a type such as % % :- type foo % ---> f(a) % ; g(a, b, c) % ; h. % % we want to generate the code % % index(X, Index) :- % ( % X = f, % Index = 0 % ; % X = g(_, _, _), % Index = 1 % ; % X = h(_), % Index = 2 % ). % :- pred generate_index_proc_body_du(spec_pred_defn_info::in, list(constructor_repn)::in, prog_var::in, prog_var::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. generate_index_proc_body_du(SpecDefnInfo, CtorRepns, X, Index, Clause, !Info) :- list.map_foldl2(generate_index_du_case(SpecDefnInfo, X, Index), CtorRepns, Disjuncts, 0, _, !Info), Context = SpecDefnInfo ^ spdi_context, goal_info_init(Context, GoalInfo), Goal = hlds_goal(disj(Disjuncts), GoalInfo), quantify_clause_body(all_modes, [X, Index], Goal, Context, Clause, !Info). :- pred generate_index_du_case(spec_pred_defn_info::in, prog_var::in, prog_var::in, constructor_repn::in, hlds_goal::out, int::in, int::out, unify_proc_info::in, unify_proc_info::out) is det. generate_index_du_case(SpecDefnInfo, X, Index, CtorRepn, Goal, !N, !Info) :- CtorRepn = ctor_repn(_Ordinal, MaybeExistConstraints, FunctorName, _ConsTag, ArgRepns, FunctorArity, _Ctxt), TypeCtor = SpecDefnInfo ^ spdi_type_ctor, FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor), make_fresh_vars_for_cons_args(ArgRepns, MaybeExistConstraints, ArgVars, !Info), Context = SpecDefnInfo ^ spdi_context, create_pure_atomic_complicated_unification(X, rhs_functor(FunctorConsId, is_not_exist_constr, ArgVars), Context, umc_explicit, [], GoalUnifyX), make_int_const_construction(Context, Index, !.N, UnifyIndexGoal), !:N = !.N + 1, GoalList = [GoalUnifyX, UnifyIndexGoal], goal_info_init(GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), conj_list_to_goal(GoalList, GoalInfo, Goal). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% % % Utility predicates. % :- pred get_du_base_type(module_info::in, tvarset::in, mer_type::in, mer_type::out) is det. get_du_base_type(ModuleInfo, TVarSet, Type, BaseType) :- module_info_get_type_table(ModuleInfo, TypeTable), get_du_base_type_loop(TypeTable, TVarSet, Type, BaseType). :- pred get_du_base_type_loop(type_table::in, tvarset::in, mer_type::in, mer_type::out) is det. get_du_base_type_loop(TypeTable, TVarSet, Type, BaseType) :- % Circular subtype definitions are assumed to have been detected by now. type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs), hlds_data.lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( TypeBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(_, MaybeSuperType, _, _MaybeRepn, _), ( MaybeSuperType = not_a_subtype, BaseType = Type ; MaybeSuperType = subtype_of(SuperType0), hlds_data.get_type_defn_tvarset(TypeDefn, TypeDefnTVarSet), hlds_data.get_type_defn_tparams(TypeDefn, TypeDefnTypeParams), merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs, TypeDefnTVarSet, TypeDefnTypeParams, SuperType0, SuperType), get_du_base_type_loop(TypeTable, TVarSet, SuperType, BaseType) ) ; TypeBody = hlds_abstract_type(_), unexpected($pred, "abstract type") ; TypeBody = hlds_eqv_type(_), unexpected($pred, "eqv type") ; TypeBody = hlds_foreign_type(_), unexpected($pred, "foreign type") ; TypeBody = hlds_solver_type(_), unexpected($pred, "solver type") ). :- pred merge_tvarsets_and_subst_type_args(tvarset::in, list(mer_type)::in, tvarset::in, list(type_param)::in, mer_type::in, mer_type::out) is det. merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs, TVarSet0, TypeParams0, Type0, Type) :- tvarset_merge_renaming(TVarSet, TVarSet0, _MergedTVarSet, Renaming), apply_variable_renaming_to_tvar_list(Renaming, TypeParams0, TypeParams), map.from_corresponding_lists(TypeParams, TypeArgs, TSubst), apply_variable_renaming_to_type(Renaming, Type0, Type1), apply_rec_subst_to_type(TSubst, Type1, Type). %---------------------------------------------------------------------------% :- pred build_simple_call(module_info::in, module_name::in, string::in, list(prog_var)::in, prog_context::in, hlds_goal::out) is det. build_simple_call(ModuleInfo, ModuleName, PredName, ArgVars, Context, Goal) :- generate_plain_call(ModuleInfo, pf_predicate, ModuleName, PredName, [], ArgVars, instmap_delta_bind_no_var, mode_no(0), detism_erroneous, purity_pure, [], Context, Goal). :- pred build_spec_pred_call(type_ctor::in, special_pred_id::in, list(prog_var)::in, instmap_delta::in, determinism::in, prog_context::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. build_spec_pred_call(TypeCtor, SpecialPredId, ArgVars, InstmapDelta, Detism, Context, Goal, !Info) :- info_get_module_info(!.Info, ModuleInfo), get_special_proc_det(ModuleInfo, TypeCtor, SpecialPredId, PredName, PredId, ProcId), GoalExpr = plain_call(PredId, ProcId, ArgVars, not_builtin, no, PredName), set_of_var.list_to_set(ArgVars, NonLocals), goal_info_init(NonLocals, InstmapDelta, Detism, purity_pure, GoalInfo0), goal_info_set_context(Context, GoalInfo0, GoalInfo), Goal = hlds_goal(GoalExpr, GoalInfo). %---------------------------------------------------------------------------% % We can start unify and compare predicates that may call other predicates % with an equality test, since it often succeeds, and when it does, it is % faster than executing the rest of the predicate body. % :- pred maybe_wrap_with_pretest_equality(prog_context::in, prog_var::in, prog_var::in, maybe(prog_var)::in, hlds_goal::in, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. maybe_wrap_with_pretest_equality(Context, X, Y, MaybeCompareRes, Goal0, Goal, !Info) :- ModuleInfo = !.Info ^ upi_module_info, module_info_get_globals(ModuleInfo, Globals), lookup_bool_option(Globals, should_pretest_equality, ShouldPretestEq), ( ShouldPretestEq = no, Goal = Goal0 ; ShouldPretestEq = yes, CastType = get_pretest_equality_cast_type(!.Info), info_new_var("CastX", CastType, CastX, !Info), info_new_var("CastY", CastType, CastY, !Info), generate_cast(unsafe_type_cast, X, CastX, Context, CastXGoal0), generate_cast(unsafe_type_cast, Y, CastY, Context, CastYGoal0), goal_add_feature(feature_keep_constant_binding, CastXGoal0, CastXGoal), goal_add_feature(feature_keep_constant_binding, CastYGoal0, CastYGoal), create_pure_atomic_complicated_unification(CastX, rhs_var(CastY), Context, umc_explicit, [], EqualityGoal0), goal_add_feature(feature_pretest_equality_condition, EqualityGoal0, EqualityGoal), CondGoalExpr = conj(plain_conj, [CastXGoal, CastYGoal, EqualityGoal]), goal_info_init(Context, ContextGoalInfo), CondGoal = hlds_goal(CondGoalExpr, ContextGoalInfo), ( MaybeCompareRes = no, EqualGoal = true_goal_with_context(Context), GoalInfo = ContextGoalInfo ; MaybeCompareRes = yes(Res), make_const_construction(Context, Res, compare_cons_id("="), EqualGoal), EqualGoal = hlds_goal(_, EqualGoalInfo), InstmapDelta = goal_info_get_instmap_delta(EqualGoalInfo), goal_info_set_instmap_delta(InstmapDelta, ContextGoalInfo, GoalInfo) ), GoalExpr = if_then_else([], CondGoal, EqualGoal, Goal0), goal_info_add_feature(feature_pretest_equality, GoalInfo, FeaturedGoalInfo), Goal = hlds_goal(GoalExpr, FeaturedGoalInfo) ). :- func get_pretest_equality_cast_type(unify_proc_info) = mer_type. get_pretest_equality_cast_type(Info) = CastType :- ModuleInfo = Info ^ upi_module_info, module_info_get_globals(ModuleInfo, Globals), lookup_bool_option(Globals, pretest_equality_cast_pointers, CastPointers), ( CastPointers = yes, CastType = c_pointer_type ; CastPointers = no, CastType = int_type ). %---------------------------------------------------------------------------% :- pred quantify_clause_body(clause_applicable_modes::in, list(prog_var)::in, hlds_goal::in, prog_context::in, clause::out, unify_proc_info::in, unify_proc_info::out) is det. quantify_clause_body(ApplModes, HeadVars, Goal0, Context, Clause, !Info) :- info_get_var_table(!.Info, VarTable0), info_get_rtti_varmaps(!.Info, RttiVarMaps0), implicitly_quantify_clause_body_general(ord_nl_maybe_lambda, HeadVars, _Warnings, Goal0, Goal, VarTable0, VarTable, RttiVarMaps0, RttiVarMaps), info_set_var_table(VarTable, !Info), info_set_rtti_varmaps(RttiVarMaps, !Info), Clause = clause(ApplModes, Goal, impl_lang_mercury, Context, []). %---------------------------------------------------------------------------% :- func compare_type_ctor = type_ctor. compare_type_ctor = TypeCtor :- Builtin = mercury_public_builtin_module, TypeCtor = type_ctor(qualified(Builtin, "comparison_result"), 0). :- func compare_cons_id(string) = cons_id. compare_cons_id(Name) = cons(SymName, 0, compare_type_ctor) :- SymName = qualified(mercury_public_builtin_module, Name). :- func compare_functor(string) = unify_rhs. compare_functor(Name) = rhs_functor(compare_cons_id(Name), is_not_exist_constr, []). %---------------------------------------------------------------------------% :- type maybe_give_vars_types ---> do_not_give_vars_types ; give_vars_types. :- pred compute_exist_constraint_implications(maybe_cons_exist_constraints::in, existq_tvars::out, maybe_give_vars_types::out) is det. compute_exist_constraint_implications(MaybeExistConstraints, ExistQTVars, GiveVarsTypes) :- ( MaybeExistConstraints = no_exist_constraints, ExistQTVars = [], GiveVarsTypes = give_vars_types ; MaybeExistConstraints = exist_constraints(ExistConstraints), ExistConstraints = cons_exist_constraints(ExistQTVars, _Constraints, _UnconstrainedQTVars, _ConstrainedQTVars), % If there are existential types involved, then it is too hard to get % the types right here (it would require allocating new type variables) % -- instead, typecheck.m will typecheck the clause to figure out % the correct types. So we just allocate the variables and leave it % up to typecheck.m to infer their types. GiveVarsTypes = do_not_give_vars_types ). %---------------------% :- pred make_ptag_and_cell_offset_args(int::in, ptag::in, cell_offset::in, prog_context::in, list(foreign_arg)::out, list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det. make_ptag_and_cell_offset_args(ArgNum, Ptag, CellOffset, Context, Args, Goals, !Info) :- Ptag = ptag(PtagUint8), PtagInt = uint8.cast_to_int(PtagUint8), make_fresh_int_var_and_arg(Context, "Ptag", ArgNum, PtagInt, PtagForeignArg, MakePtagGoal, !Info), CellOffset = cell_offset(CellOffsetInt), make_fresh_int_var_and_arg(Context, "CellOffsetVar", ArgNum, CellOffsetInt, CellOffsetForeignArg, MakeCellOffsetGoal, !Info), Args = [PtagForeignArg, CellOffsetForeignArg], Goals = [MakePtagGoal, MakeCellOffsetGoal]. %---------------------% :- pred make_fresh_vars(maybe_give_vars_types::in, string::in, list(constructor_arg_repn)::in, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_vars(GiveVarsTypes, Prefix, CtorArgRepns, Vars, !Info) :- make_fresh_vars_loop(GiveVarsTypes, Prefix, 1, CtorArgRepns, Vars, !Info). :- pred make_fresh_vars_loop(maybe_give_vars_types::in, string::in, int::in, list(constructor_arg_repn)::in, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_vars_loop(_GiveVarsTypes, _Prefix, _ArgNum, [], [], !Info). make_fresh_vars_loop(GiveVarsTypes, Prefix, ArgNum, [CtorArgRepn | CtorArgRepns], [Var | Vars], !Info) :- make_fresh_var(GiveVarsTypes, Prefix, ArgNum, CtorArgRepn ^ car_type, Var, !Info), make_fresh_vars_loop(GiveVarsTypes, Prefix, ArgNum + 1, CtorArgRepns, Vars, !Info). :- pred make_fresh_var(maybe_give_vars_types::in, string::in, int::in, mer_type::in, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_var(GiveVarsTypes, Prefix, Num, Type, Var, !Info) :- NumStr = string.int_to_string(Num), Name = Prefix ++ NumStr, info_new_var_maybe_type(GiveVarsTypes, Name, Type, Var, !Info). %---------------------% :- pred make_fresh_var_pair(maybe_give_vars_types::in, string::in, string::in, int::in, mer_type::in, prog_var::out, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_var_pair(GiveVarsTypes, PrefixX, PrefixY, Num, Type, VarX, VarY, !Info) :- NumStr = string.int_to_string(Num), NameX = PrefixX ++ NumStr, NameY = PrefixY ++ NumStr, info_new_var_maybe_type(GiveVarsTypes, NameX, Type, VarX, !Info), info_new_var_maybe_type(GiveVarsTypes, NameY, Type, VarY, !Info). %---------------------% :- pred make_fresh_vars_for_cons_args(list(constructor_arg_repn)::in, maybe_cons_exist_constraints::in, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_vars_for_cons_args(CtorArgs, MaybeExistConstraints, Vars, !Info) :- ( MaybeExistConstraints = no_exist_constraints, ArgTypes = list.map(func(C) = C ^ car_type, CtorArgs), make_fresh_vars_from_types(ArgTypes, Vars, !Info) ; MaybeExistConstraints = exist_constraints(_ExistConstraints), % If there are existential types involved, then it is too hard to get % the types right here (it would require allocating new type variables) % -- instead, typecheck.m will typecheck the clause to figure out % the correct types. So we just allocate the variables and leave it % up to typecheck.m to infer their types. list.length(CtorArgs, NumVars), list.duplicate(NumVars, "", VarNames), list.map_foldl(info_new_var_no_type, VarNames, Vars, !Info) ). :- pred make_fresh_vars_from_types(list(mer_type)::in, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_vars_from_types([], [], !Info). make_fresh_vars_from_types([Type | Types], [Var | Vars], !Info) :- info_new_var("", Type, Var, !Info), make_fresh_vars_from_types(Types, Vars, !Info). %---------------------% :- pred make_fresh_named_vars_from_types(list(mer_type)::in, string::in, int::in, list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_named_vars_from_types([], _, _, [], !Info). make_fresh_named_vars_from_types([Type | Types], BaseName, Num, [Var | Vars], !Info) :- make_fresh_named_var_from_type(Type, BaseName, Num, Var, !Info), make_fresh_named_vars_from_types(Types, BaseName, Num + 1, Vars, !Info). :- pred make_fresh_named_var_from_type(mer_type::in, string::in, int::in, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_named_var_from_type(Type, BaseName, Num, Var, !Info) :- string.int_to_string(Num, NumStr), string.append(BaseName, NumStr, Name), info_new_var(Name, Type, Var, !Info). %---------------------------------------------------------------------------% :- pred make_fresh_int_var_and_arg(prog_context::in, string::in, int::in, int::in, foreign_arg::out, hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det. make_fresh_int_var_and_arg(Context, Name, SuffixInt, Value, Arg, Goal, !Info) :- Type = int_type, make_fresh_var(give_vars_types, Name, SuffixInt, Type, Var, !Info), Arg = foreign_arg(Var, yes(foreign_arg_name_mode(Name, in_mode)), Type, bp_native_if_possible), make_int_const_construction(Context, Var, Value, Goal). %---------------------------------------------------------------------------% :- func compute_maybe_packable_args_locn(cons_tag) = maybe_packable_args. compute_maybe_packable_args_locn(ConsTag) = ArgsLocn :- ( ConsTag = remote_args_tag(RemoteArgsTagInfo), ( RemoteArgsTagInfo = remote_args_only_functor, Ptag = ptag(0u8) ; RemoteArgsTagInfo = remote_args_unshared(Ptag) ; RemoteArgsTagInfo = remote_args_shared(Ptag, _) ; RemoteArgsTagInfo = remote_args_ctor(_), % This is a dummy ptag. We enable the use of remote_args_ctors % data type representations only in grades where we won't be % doing any argument packing, which means we also won't be doing % any bulk comparisons of packed arguments. Ptag = ptag(0u8) ), ArgsLocn = packable_args(args_remote(Ptag)) ; ConsTag = local_args_tag(_), ArgsLocn = packable_args(args_local) ; ( ConsTag = no_tag ; ConsTag = direct_arg_tag(_) ), ArgsLocn = unpackable_args ; ( ConsTag = int_tag(_) ; ConsTag = float_tag(_) ; ConsTag = string_tag(_) ; ConsTag = foreign_tag(_, _) ; ConsTag = dummy_tag ; ConsTag = shared_local_tag_no_args(_, _, _) ; ConsTag = ground_term_const_tag(_, _) ; ConsTag = type_info_const_tag(_) ; ConsTag = typeclass_info_const_tag(_) ; ConsTag = type_ctor_info_tag(_, _, _) ; ConsTag = base_typeclass_info_tag(_, _, _) ; ConsTag = deep_profiling_proc_layout_tag(_, _) ; ConsTag = tabling_info_tag(_, _) ; ConsTag = table_io_entry_tag(_, _) ; ConsTag = closure_tag(_, _, _) ), % These ConsTags are for terms that have no arguments. % *If* we can compare constants as ints, we should never get here, % but in some situations (such as the now-deleted Erlang grade), % we cannot compare them as ints, which *does* allow us to get here. ArgsLocn = unpackable_args ). %---------------------------------------------------------------------------% % We want to know whether a bulk comparison operation applies % only to *some* of the arguments packed together into a word, % or it *all* of the arguments packed together in a word, because % in the latter case, we can avoid the shift and mask operations % required to extract each bitfield from its word. (We always store % zeroes in the bits in a packed word that do not store arguments.) % % As we process the arguments to include in a bulk compare operation, % we use this type to keep track. The default is all_args_in_word_so_far, % but we fall back to not_all_args_in_word_so_far when we find an argument % that cannot be part of the bulk compare operation. We can go back to % all_args_in_word_so_far only when we get to the next packed word. % :- type maybe_all_args_in_word_so_far ---> not_all_args_in_word_so_far ; all_args_in_word_so_far. %---------------------------------------------------------------------------% :- type args_locn ---> args_local ; args_remote(ptag). :- type maybe_packable_args ---> unpackable_args ; packable_args(args_locn). :- type uc_params ---> uc_params( ucp_module_info :: module_info, ucp_context :: prog_context, ucp_existq_tvars :: existq_tvars, ucp_maybe_packable_args :: maybe_packable_args, ucp_give_vars_types :: maybe_give_vars_types, ucp_constants_as_ints :: maybe_compare_constants_as_ints, ucp_packed_unify_compare :: maybe_allow_packed_unify_compare ). %---------------------------------------------------------------------------% :- type unify_proc_info ---> unify_proc_info( upi_module_info :: module_info, upi_var_table :: var_table, upi_rtti_varmaps :: rtti_varmaps, upi_packed_ops :: maybe_packed_word_ops ). :- type maybe_packed_word_ops ---> used_no_packed_word_ops ; used_some_packed_word_ops. :- pred info_init(module_info::in, unify_proc_info::out) is det. info_init(ModuleInfo, Info) :- init_var_table(VarTable), rtti_varmaps_init(RttiVarMaps), Info = unify_proc_info(ModuleInfo, VarTable, RttiVarMaps, used_no_packed_word_ops). :- pred info_get_module_info(unify_proc_info::in, module_info::out) is det. :- pred info_get_var_table(unify_proc_info::in, var_table::out) is det. :- pred info_get_rtti_varmaps(unify_proc_info::in, rtti_varmaps::out) is det. info_get_module_info(Info, X) :- X = Info ^ upi_module_info. info_get_var_table(Info, X) :- X = Info ^ upi_var_table. info_get_rtti_varmaps(Info, X) :- X = Info ^ upi_rtti_varmaps. :- pred info_set_module_info(module_info::in, unify_proc_info::in, unify_proc_info::out) is det. :- pred info_set_var_table(var_table::in, unify_proc_info::in, unify_proc_info::out) is det. :- pred info_set_rtti_varmaps(rtti_varmaps::in, unify_proc_info::in, unify_proc_info::out) is det. :- pred info_set_packed_ops(maybe_packed_word_ops::in, unify_proc_info::in, unify_proc_info::out) is det. info_set_module_info(X, !Info) :- !Info ^ upi_module_info := X. info_set_var_table(X, !Info) :- !Info ^ upi_var_table := X. info_set_rtti_varmaps(X, !Info) :- !Info ^ upi_rtti_varmaps := X. info_set_packed_ops(X, !Info) :- !Info ^ upi_packed_ops := X. %---------------------% :- pred info_new_var(string::in, mer_type::in, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. info_new_var(Name, Type, Var, !Info) :- ModuleInfo = !.Info ^ upi_module_info, IsDummy = is_type_a_dummy(ModuleInfo, Type), Entry = vte(Name, Type, IsDummy), VarTable0 = !.Info ^ upi_var_table, add_var_entry(Entry, Var, VarTable0, VarTable), !Info ^ upi_var_table := VarTable. :- pred info_new_var_no_type(string::in, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. info_new_var_no_type(Name, Var, !Info) :- Type = void_type, IsDummy = is_dummy_type, Entry = vte(Name, Type, IsDummy), VarTable0 = !.Info ^ upi_var_table, add_var_entry(Entry, Var, VarTable0, VarTable), !Info ^ upi_var_table := VarTable. :- pred info_new_var_maybe_type(maybe_give_vars_types::in, string::in, mer_type::in, prog_var::out, unify_proc_info::in, unify_proc_info::out) is det. info_new_var_maybe_type(GiveVarsTypes, Name, Type, Var, !Info) :- ( GiveVarsTypes = give_vars_types, info_new_var(Name, Type, Var, !Info) ; GiveVarsTypes = do_not_give_vars_types, info_new_var_no_type(Name, Var, !Info) ). :- pred info_extract(unify_proc_info::in, module_info::out, var_table::out) is det. info_extract(Info, ModuleInfo, VarTable) :- ModuleInfo = Info ^ upi_module_info, VarTable = Info ^ upi_var_table. %---------------------------------------------------------------------------% :- end_module check_hlds.unify_proc. %---------------------------------------------------------------------------%