mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 17:33:38 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
mercury/compiler/ml_unify_gen_util.m
Zoltan Somogyi ee9c7d3a84 Speed up bound vs ground inst checks. 
The code that checks whether a bound inst wrapped around
a list of bound_functors matched the ground inst did several things
in a suboptimal fashion.

- It looked up the definition of the type constructor of the relevant type
  (the type of the variable the inst is for) more than once. (This was
  not easily visible because the lookups were in different predicates.)
  This diff factors these out, not for the immesurably small speedup,
  but to make possible the fixes for the next two issues.

- To simplify the "is there a bound_functor for each constructor in the type"
  check, it sorted the constructors of the type by name and arity. (Lists of
  bound_functors are always sorted by name and arity.) Given that most
  modules contain more than one bound inst for any given type constructor,
  any sorting after the first was unnecessarily repeated work. This diff
  therefore extends the representation of du types, which until now has
  include only a list of the data constructors in the type definition
  in definition order, with a list of those exact same data constructors
  in name/arity order.

- Even if a list of bound_functors lists all the constructors of a type,
  the bound inst containing them is not equivalent to ground if the inst
  of some argument of some bound_inst is not equivalent to ground.
  This means that we need to know the actual argument of each constructor.
  The du type definition lists argument types that refer to the type
  constructor's type parameters; we need the instances of these argument types
  that apply to type of the variable at hand, which usually binds concrete
  types to those type parameters.

  We used to apply the type-parameter-to-actual-type substitution to
  each argument of each data constructor in the type before we compared
  the resulting filled-in data constructor descriptions against the list of
  bound_functors. However, in cases where the comparison fails, the
  substitution applications to arguments beyond the point of failure
  are all wasted work. This diff therefore applies the substitution
  only when its result is about to be needed.

This diff leads to a speedup of about 3.5% on tools/speedtest,
and about 38% (yes, more than a third) when compiling options.m.

compiler/hlds_data.m:
    Add the new field to the representation of du types.

    Add a utility predicate that helps construct that field, since it is
    now needed by two modules (add_type.m and equiv_type_hlds.m).

    Delete two functions that were used only by det_check_switch.m,
    which this diff moves to that module (in modified form).

compiler/inst_match.m:
    Implement the first and third changes listed above, and take advantage
    of the second.

    The old call to all_du_ctor_arg_types, which this diff replaces,
    effectively lied about the list of constructors it returned,
    by simply not returning any constructors containing existentially
    quantified  types, on the grounds that they "were not handled yet".
    We now fail explicitly when we find any such constructors.

    Perform the check for one-to-one match between bound_functors and
    constructors with less argument passing.

compiler/det_check_switch.m:
    Move the code deleted from hlds_data.m here, and simplify it,
    taking advantage of the new field in du types.

compiler/Mercury.options:
    Specify --optimize-constructor-last-call for det_check_switch.m
    to optimize the updated moved code.

compiler/add_foreign_enum.m:
compiler/add_special_pred.m:
compiler/add_type.m:
compiler/check_typeclass.m:
compiler/code_info.m:
compiler/dead_proc_elim.m:
compiler/direct_arg_in_out.m:
compiler/du_type_layout.m:
compiler/equiv_type_hlds.m:
compiler/hlds_out_type_table.m:
compiler/inst_check.m:
compiler/intermod.m:
compiler/intermod_decide.m:
compiler/lookup_switch_util.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen_test.m:
compiler/ml_unify_gen_util.m:
compiler/mlds.m:
compiler/post_term_analysis.m:
compiler/recompilation.usage.m:
compiler/resolve_unify_functor.m:
compiler/simplify_goal_ite.m:
compiler/table_gen.m:
compiler/tag_switch_util.m:
compiler/term_norm.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/typecheck_coerce.m:
compiler/unify_proc.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
    Conform to the changes above. This mostly means handling
    the new field in du types (usually by ignoring it).
2025-11-19 22:09:04 +11:00

1021 lines
40 KiB
Mathematica
Raw Permalink Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1999-2012 The University of Melbourne.
% Copyright (C) 2014, 2018-2025 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.
%---------------------------------------------------------------------------%
:- module ml_backend.ml_unify_gen_util.
:- interface.
:- import_module hlds.
:- import_module hlds.const_struct.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.mlds.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.set_of_var.
:- import_module parse_tree.var_table.
:- import_module assoc_list.
:- import_module bool.
:- import_module list.
:- import_module maybe.
%---------------------------------------------------------------------------%
% Convert a cons_id for a given type to a cons_tag.
%
:- pred ml_cons_id_to_tag(ml_gen_info::in, cons_id::in, cons_tag::out) is det.
%---------------------------------------------------------------------------%
:- pred ml_type_as_field(module_info::in, bool::in, mer_type::in,
arg_width::in, mer_type::out) is det.
%---------------------------------------------------------------------------%
% Given a type and a cons_id, and also the types of the actual arguments
% of that cons_id in some particular use of it, look up the original types
% of the fields of that cons_id from the type definition. Note that the
% field types need not be the same as the actual argument types; for
% polymorphic types, the types of the actual arguments can be an instance
% of the field types.
%
:- pred ml_field_names_and_types(ml_gen_info::in, mer_type::in,
cons_id::in, cell_offset::in, list(prog_var)::in,
assoc_list(prog_var, constructor_arg_repn)::out) is det.
%---------------------------------------------------------------------------%
:- type may_have_extra_args
---> may_not_have_extra_args
; may_have_extra_args.
:- type arg_type_and_width(Arg)
---> arg_type_and_width(Arg, mer_type, arg_pos_width).
:- type arg_var_type_and_width == arg_type_and_width(prog_var).
:- type arg_const_type_and_width == arg_type_and_width(const_struct_arg).
:- type arg_to_type(Arg) == (func(Arg) = mer_type).
% cons_id_arg_types_and_widths(ModuleInfo, ArgToType, MayHaveExtraArgs,
% VarType, ConsId, Args, ArgTypesWidths):
%
% We are constructing a structure (either on the heap or in static memory).
% VarType is the type of the whole structure, ConsId is the functor,
% and Args specifies the functor's visible arguments. If MayHaveExtraArgs
% is may_have_extra_args, then the visible arguments may be prefaced
% by extra type_info and/or typeclass_info arguments added to describe
% some existentially typed visible arguments. Both Args and ArgsTypesWidths
% will include these extra arguments.
%
% The Args will usually be variables, but will be const_struct_args
% in some cases.
%
% The job of this predicate is to associate each argument with
% its type as an argument (which, due to type instantiation and/or boxing,
% may be different from the type of the corresponding constructor argument)
% and with its width.
%
% In some circumstances, the types of the non-extra arguments are taken
% from applyin ArgToType to the given argument. One of our callers
% does not need the types inside ArgsTypesWidths; such callers can supply
% dummy values for ArgToTypes, if they also pass may_not_have_extra_args.
%
:- pred associate_cons_id_args_with_types_widths(module_info, arg_to_type(Arg),
may_have_extra_args, mer_type, cons_id, list(Arg),
list(arg_type_and_width(Arg))).
:- mode associate_cons_id_args_with_types_widths(in, in,
in(bound(may_have_extra_args)), in, in, in, out) is det.
:- mode associate_cons_id_args_with_types_widths(in, in,
in(bound(may_not_have_extra_args)), in, in, in, out) is det.
:- pred specified_arg_types_and_consecutive_full_words(mer_type::in, int::in,
list(Arg)::in, list(arg_type_and_width(Arg))::out) is det.
%---------------------------------------------------------------------------%
% Given a cons_tag, return its primary tag, and the integer offset
% used to reference the first field of a structure for lowlevel data.
% Abort if the tag indicates that the data doesn't have any fields.
%
:- pred ml_tag_ptag_and_initial_offset(cons_tag::in, ptag::out,
cell_offset::out) is det.
%---------------------------------------------------------------------------%
:- type field_gen
---> field_gen(
% The primary tag, if any, for the field reference.
maybe(ptag),
% The value and the MLDS type of the pointer to the cell.
mlds_rval,
mlds_type,
% How we identify the field in the cell.
field_via
).
:- type field_via
---> field_via_offset
% We identify the field via ml_field_offset.
; field_via_name(
% We identify the field via ml_field_named.
% The MLDS module name that is the qualifier
% in the qual_field_var_name in the first argument
% of ml_field_named. (The mlds_qual_kind is type_qual.)
mlds_module_name,
% The class pointer type that is second argument of
% ml_field_named.
mlds_type
).
:- pred decide_field_gen(ml_gen_info::in, mlds_lval::in, mer_type::in,
cons_id::in, cons_tag::in, ptag::in, field_gen::out) is det.
%---------------------------------------------------------------------------%
% ml_gen_secondary_tag_rval(Info, VarType, VarRval, Ptag, SectagRval):
%
% Return the rval for the secondary tag field of VarRval, assuming that
% VarRval has the specified VarType and Ptag.
%
% Exported for use ml_tag_switch.m.
%
:- pred ml_gen_secondary_tag_rval(ml_gen_info::in, mer_type::in, mlds_rval::in,
ptag::in, mlds_rval::out) is det.
%---------------------------------------------------------------------------%
% OR together the given rvals.
%
:- func ml_bitwise_or_rvals(list(mlds_rval)) = mlds_rval.
:- func ml_bitwise_or_some_rvals(mlds_rval, list(mlds_rval)) = mlds_rval.
:- func ml_bitwise_or_two_rvals(mlds_rval, mlds_rval) = mlds_rval.
:- func ml_bitwise_mask(mlds_rval, int) = mlds_rval.
:- func ml_left_shift_rval(mlds_rval, arg_shift, fill_kind) = mlds_rval.
:- func ml_right_shift_rval(mlds_rval, arg_shift) = mlds_rval.
:- type ml_maybe_zero_const
---> ml_is_not_zero_const
; ml_is_zero_const.
:- func ml_is_zero_const(mlds_rval_const) = ml_maybe_zero_const.
%---------------------------------------------------------------------------%
:- type assign_dir
---> assign_nondummy_left
; assign_nondummy_right
; assign_nondummy_unused
; assign_dummy.
% ml_compute_assign_direction(ModuleInfo, NonLocals, ArgVar, ArgVarEntry,
% FieldType, ArgMode, Dir):
%
% Figure out in which direction the assignment goes
% between a field of a term, and the corresponding argument.
%
% This predicate differs from compute_assign_direction, because
% the MLDS backend never declares MLDS variables for HLDS variables
% of dummy types. It must therefore avoid all mention of such variables.
% This is why it must distinguish assignments involving dummy values
% even from assignments where the target is unused.
%
:- pred ml_compute_assign_direction(module_info::in, set_of_progvar::in,
prog_var::in, var_table_entry::in, mer_type::in, unify_mode::in,
assign_dir::out) is det.
%---------------------------------------------------------------------------%
:- pred local_primsectag_filled_bitfield(ml_gen_info::in,
local_args_tag_info::in, filled_bitfield::out) is det.
:- pred remote_sectag_filled_bitfield(uint::in, sectag_bits::in,
filled_bitfield::out) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.
:- import_module backend_libs.builtin_ops.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_pred.
:- import_module hlds.mode_top_functor.
:- import_module hlds.type_util.
:- import_module libs.
:- import_module libs.globals.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_type_gen.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_test.
:- import_module int.
:- import_module pair.
:- import_module require.
:- import_module term_context.
:- import_module uint.
:- import_module uint8.
:- import_module varset.
%---------------------------------------------------------------------------%
ml_cons_id_to_tag(Info, ConsId, ConsTag) :-
ml_gen_info_get_module_info(Info, ModuleInfo),
ConsTag = cons_id_to_tag(ModuleInfo, ConsId).
%---------------------------------------------------------------------------%
ml_type_as_field(ModuleInfo, HighLevelData, FieldType, FieldWidth,
BoxedFieldType) :-
( if
(
HighLevelData = no,
% With the low-level data representation, we store all fields
% except for double-width floats as "boxed" so we ignore the
% original field type and instead generate a polymorphic type
% BoxedFieldType which we use for the type of the field. This type
% is used in the calls to ml_gen_box_or_unbox_rval to ensure that
% we box values when storing them into fields and unbox them when
% extracting them from fields.
FieldWidth \= aw_double_word
;
HighLevelData = yes,
% With the high-level data representation, we don't box everything,
% but for the MLDS->C backend, we still need to box floating point
% fields if they are wider than a word.
ml_must_box_field_type(ModuleInfo, FieldType, FieldWidth)
)
then
% XXX zs: I do not see any reason why TypeVar cannot be confused with
% other type variables (whether constructed the same way or not),
% nor do I see any reason why such confusion would not lead to errors.
varset.init(TypeVarSet0),
varset.new_var(TypeVar, TypeVarSet0, _TypeVarSet),
% The kind is `star' since there are values with this type.
BoxedFieldType = type_variable(TypeVar, kind_star)
else
BoxedFieldType = FieldType
).
%---------------------------------------------------------------------------%
ml_field_names_and_types(Info, Type, ConsId, InitOffset, ArgVars,
ArgVarRepns) :-
% Lookup the field types for the arguments of this cons_id.
InitOffset = cell_offset(InitOffsetInt),
( if type_is_tuple(Type, _) then
% Fields in tuples are all word-sized, and have no extra type_infos
% and/or typeclass_infos in front of them. Their types are all
% unbound type variables.
allocate_consecutive_ctor_arg_repns_for_tuple(InitOffsetInt,
ArgVars, ArgVarRepns)
else
ml_gen_info_get_module_info(Info, ModuleInfo),
get_cons_id_repn_defn_det(ModuleInfo, ConsId, ConsRepnDefn),
CtorArgRepns = ConsRepnDefn ^ cr_args,
% Add the fields for any type_infos and/or typeclass_infos inserted
% for existentially quantified data types. For these, we just copy
% the types of the initial ArgVars.
list.length(ArgVars, NumArgVars),
list.length(CtorArgRepns, NumCtorArgs),
NumExtraArgVars = NumArgVars - NumCtorArgs,
( if NumExtraArgVars > 0 then
list.split_upto(NumExtraArgVars, ArgVars,
ExtraArgVars, NonExtraArgVars),
% The extra type_infos and/or typeclass_infos are all stored
% in one full word each.
allocate_consecutive_ctor_arg_repns_for_extra_args(Info,
InitOffsetInt, ExtraArgVars, ExtraArgVarRepns),
assoc_list.from_corresponding_lists(NonExtraArgVars, CtorArgRepns,
NonExtraArgVarRepns),
ArgVarRepns = ExtraArgVarRepns ++ NonExtraArgVarRepns
else
assoc_list.from_corresponding_lists(ArgVars, CtorArgRepns,
ArgVarRepns)
)
).
:- pred allocate_consecutive_ctor_arg_repns_for_tuple(int::in,
list(prog_var)::in,
assoc_list(prog_var, constructor_arg_repn)::out) is det.
allocate_consecutive_ctor_arg_repns_for_tuple(_, [], []).
allocate_consecutive_ctor_arg_repns_for_tuple(CurOffset,
[Var | Vars], [VarArgRepn | VarArgRepns]) :-
Type = ml_make_boxed_type,
ArgPosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
ArgRepn = ctor_arg_repn(no, no_base_ctor_arg, Type, ArgPosWidth,
dummy_context),
VarArgRepn = Var - ArgRepn,
allocate_consecutive_ctor_arg_repns_for_tuple(CurOffset + 1,
Vars, VarArgRepns).
:- pred allocate_consecutive_ctor_arg_repns_for_extra_args(ml_gen_info::in,
int::in, list(prog_var)::in,
assoc_list(prog_var, constructor_arg_repn)::out) is det.
allocate_consecutive_ctor_arg_repns_for_extra_args(_, _, [], []).
allocate_consecutive_ctor_arg_repns_for_extra_args(Info, CurOffset,
[Var | Vars], [VarArgRepn | VarArgRepns]) :-
ml_variable_type_direct(Info, Var, Type),
ArgPosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
ArgRepn = ctor_arg_repn(no, no_base_ctor_arg, Type, ArgPosWidth,
dummy_context),
VarArgRepn = Var - ArgRepn,
allocate_consecutive_ctor_arg_repns_for_extra_args(Info, CurOffset + 1,
Vars, VarArgRepns).
%---------------------------------------------------------------------------%
associate_cons_id_args_with_types_widths(ModuleInfo, ArgToType,
MayHaveExtraArgs, VarType, ConsId, Args, ArgsTypesWidths) :-
( if
ConsId = du_data_ctor(DuCtor),
not is_introduced_type_info_type(VarType)
then
( if get_cons_repn_defn(ModuleInfo, DuCtor, ConsRepnDefn) then
ConsArgRepns = ConsRepnDefn ^ cr_args,
NumExtraArgs = list.length(Args) - list.length(ConsArgRepns),
( if NumExtraArgs = 0 then
zip_args_types_widths(Args, ConsArgRepns, ArgsTypesWidths)
else
expect(unify(MayHaveExtraArgs, may_have_extra_args), $pred,
"extra args in static struct"),
% There may have been additional types inserted to hold the
% type_infos and type_class_infos for existentially quantified
% types. We can get the type of these from VarTypes.
det_split_list(NumExtraArgs, Args, ExtraArgs, NonExtraArgs),
( if
ConsRepnDefn ^ cr_tag = remote_args_tag(RemoteArgsTagInfo),
RemoteArgsTagInfo = remote_args_shared(_, RemoteSectag),
RemoteSectag = remote_sectag(_, SectagSize),
SectagSize = rsectag_word
then
InitOffset = 1
else
InitOffset = 0
),
lookup_type_and_allocate_consecutive_full_words(ArgToType,
InitOffset, ExtraArgs, ExtraArgsTypesWidths),
zip_args_types_widths(NonExtraArgs, ConsArgRepns,
NonExtraArgsTypesWidths),
ArgsTypesWidths =
ExtraArgsTypesWidths ++ NonExtraArgsTypesWidths
)
else if
% If we didn't find a constructor definition, maybe that is
% because this type was a built-in type.
type_is_tuple(VarType, _)
then
% In this case, the argument types are all fresh variables.
% Note that we do not need to worry about using the right varset
% here, since all we really care about at this point is whether
% something is a type variable or not, not which type variable
% it is.
InitOffset = 0,
specified_arg_types_and_consecutive_full_words(ml_make_boxed_type,
InitOffset, Args, ArgsTypesWidths)
else
% The only builtin types that can allocate structures
% are tuples and the RTTI-related types. Both should have been
% handled by code above.
unexpected($pred, "get_cons_defn failed")
)
else
% For cases when ConsId \= hlds_cons(_, _) and it is not a tuple,
% as can happen e.g. for closures and type_infos, we assume that
% the arguments all have the right type already, and that there
% is no secondary tag.
InitOffset = 0,
lookup_type_and_allocate_consecutive_full_words(ArgToType,
InitOffset, Args, ArgsTypesWidths)
).
:- pred zip_args_types_widths(list(Arg)::in,
list(constructor_arg_repn)::in, list(arg_type_and_width(Arg))::out) is det.
zip_args_types_widths([], [], []).
zip_args_types_widths([], [_ | _], _) :-
unexpected($pred, "length mismatch").
zip_args_types_widths([_ | _], [], _) :-
unexpected($pred, "length mismatch").
zip_args_types_widths([Arg | Args], [ConsArgRepn | ConsArgRepns],
[ArgTypeWidth | ArgsTypesWidth]) :-
ArgTypeWidth = arg_type_and_width(Arg,
ConsArgRepn ^ car_type, ConsArgRepn ^ car_pos_width),
zip_args_types_widths(Args, ConsArgRepns, ArgsTypesWidth).
:- pred lookup_type_and_allocate_consecutive_full_words(arg_to_type(Arg)::in,
int::in, list(Arg)::in, list(arg_type_and_width(Arg))::out) is det.
lookup_type_and_allocate_consecutive_full_words(_, _, [], []).
lookup_type_and_allocate_consecutive_full_words(ArgToType, CurOffset,
[Arg | Args], [ArgTypeWidth | ArgsTypesWidths]) :-
PosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
ArgTypeWidth = arg_type_and_width(Arg, ArgToType(Arg), PosWidth),
lookup_type_and_allocate_consecutive_full_words(ArgToType, CurOffset + 1,
Args, ArgsTypesWidths).
specified_arg_types_and_consecutive_full_words(_, _, [], []).
specified_arg_types_and_consecutive_full_words(Type, CurOffset,
[Arg | Args], [ArgTypeWidth | ArgsTypesWidths]) :-
PosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
ArgTypeWidth = arg_type_and_width(Arg, Type, PosWidth),
specified_arg_types_and_consecutive_full_words(Type, CurOffset + 1,
Args, ArgsTypesWidths).
%---------------------------------------------------------------------------%
ml_tag_ptag_and_initial_offset(ConsTag, Ptag, InitOffset) :-
% XXX ARG_PACK Check our callers whether this predicate is actually needed,
% or whether our callers could get Ptag and InitOffset more cheaply.
(
ConsTag = remote_args_tag(RemoteArgsTagInfo),
(
RemoteArgsTagInfo = remote_args_only_functor,
Ptag = ptag(0u8),
InitOffset = cell_offset(0)
;
RemoteArgsTagInfo = remote_args_unshared(Ptag),
InitOffset = cell_offset(0)
;
RemoteArgsTagInfo = remote_args_shared(Ptag, RemoteSectag),
RemoteSectag = remote_sectag(_, SectagSize),
(
SectagSize = rsectag_word,
InitOffset = cell_offset(1)
;
SectagSize = rsectag_subword(_),
InitOffset = cell_offset(0)
)
;
RemoteArgsTagInfo = remote_args_ctor(_Data),
Ptag = ptag(0u8),
InitOffset = cell_offset(0)
)
;
ConsTag = direct_arg_tag(Ptag),
InitOffset = cell_offset(0)
;
ConsTag = ground_term_const_tag(_, SubTag),
ml_tag_ptag_and_initial_offset(SubTag, Ptag, InitOffset)
;
( ConsTag = string_tag(_String)
; ConsTag = int_tag(_)
; ConsTag = foreign_tag(_, _)
; ConsTag = float_tag(_Float)
; ConsTag = dummy_tag
; ConsTag = closure_tag(_, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
; ConsTag = type_info_const_tag(_)
; ConsTag = typeclass_info_const_tag(_)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = deep_profiling_proc_layout_tag(_, _)
; ConsTag = table_io_entry_tag(_, _)
; ConsTag = no_tag
; ConsTag = shared_local_tag_no_args(_, _, _)
; ConsTag = local_args_tag(_)
),
unexpected($pred, "unexpected tag")
).
%---------------------------------------------------------------------------%
decide_field_gen(Info, VarLval, VarType, ConsId, ConsTag, Ptag, FieldGen) :-
AddrRval = ml_lval(VarLval),
ml_gen_mlds_type(Info, VarType, AddrType),
ml_gen_info_get_high_level_data(Info, HighLevelData),
(
HighLevelData = no,
% With the low-level data representation, we access all fields
% using offsets.
FieldVia = field_via_offset
;
HighLevelData = yes,
% With the high-level data representation, we always use named fields,
% except for tuple types.
( if type_is_tuple(VarType, _) then
FieldVia = field_via_offset
else if ConsId = du_data_ctor(DuCtor) then
DuCtor = du_ctor(ConsSymName, ConsArity, ConsTypeCtor),
ml_gen_info_get_module_info(Info, ModuleInfo),
ml_gen_info_get_target(Info, Target),
% XXX ARG_PACK Delete this sanity test after it has been tested
% for a while.
type_to_ctor_det(VarType, VarTypeCtor),
expect(unify(ConsTypeCtor, VarTypeCtor), $pred,
"ConsTypeCtor != VarTypeCtor"),
% With the high-level data representation, subtypes use the same
% class as their base type constructor, whose field names are
% derived from the base type constructor.
module_info_get_type_table(ModuleInfo, TypeTable),
( if get_base_type_ctor(TypeTable, ConsTypeCtor, BaseTypeCtor) then
TypeCtor = BaseTypeCtor
else
TypeCtor = ConsTypeCtor
),
ml_gen_class_name(TypeCtor, QualTypeName, TypeArity),
QualTypeName = qual_class_name(MLDS_Module, QualKind, TypeName),
TypeQualifier = mlds_append_class_qualifier(Target, MLDS_Module,
QualKind, TypeName, TypeArity),
UsesBaseClass = ml_tag_uses_base_class(ConsTag),
(
UsesBaseClass = tag_uses_base_class,
% There is only one functor for the type, and so
% the class name is determined by the type name.
ClassId = mlds_class_id(QualTypeName, TypeArity),
FieldQualifier = TypeQualifier
;
UsesBaseClass = tag_does_not_use_base_class,
% The class name is determined by the constructor.
ConsName = ml_gen_du_ctor_name(Target, TypeCtor,
ConsSymName, ConsArity),
QualConsName =
qual_class_name(TypeQualifier, type_qual, ConsName),
ClassId = mlds_class_id(QualConsName, ConsArity),
FieldQualifier = mlds_append_class_qualifier(Target,
TypeQualifier, type_qual, ConsName, ConsArity)
),
ClassPtrType = mlds_ptr_type(mlds_class_type(ClassId)),
FieldVia = field_via_name(FieldQualifier, ClassPtrType)
else
unexpected($pred, "unexpected cons_id")
)
),
FieldGen = field_gen(yes(Ptag), AddrRval, AddrType, FieldVia).
%---------------------------------------------------------------------------%
ml_gen_secondary_tag_rval(Info, VarType, Rval, Ptag, SectagFieldRval) :-
ml_gen_info_get_high_level_data(Info, HighLevelData),
ml_gen_info_get_module_info(Info, ModuleInfo),
MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
IntType = mlds_builtin_type_int(int_type_int),
(
HighLevelData = no,
% Note: with the low-level data representation, all fields are boxed,
% even the secondary tag, and so we need to unbox (i.e. cast) it
% back to the right type here.
SectagFieldRval =
ml_unbox(IntType,
ml_lval(ml_field(yes(Ptag), Rval, MLDS_VarType,
ml_field_offset(ml_const(mlconst_int(0))),
mlds_generic_type)))
;
HighLevelData = yes,
ml_gen_info_get_target(Info, Target),
FieldId = ml_gen_hl_tag_field_id(ModuleInfo, Target, VarType),
SectagFieldRval = ml_lval(ml_field(yes(Ptag), Rval, MLDS_VarType,
FieldId, IntType))
).
% Return the field_id for the "data_tag" field of the specified
% Mercury type, which holds the secondary tag.
%
:- func ml_gen_hl_tag_field_id(module_info, mlds_target_lang, mer_type)
= mlds_field_id.
ml_gen_hl_tag_field_id(ModuleInfo, Target, Type) = FieldId :-
% Figure out the type name and arity.
type_to_ctor_det(Type, TypeCtor),
ml_gen_class_name(TypeCtor, QualifiedTypeName, TypeArity),
QualifiedTypeName = qual_class_name(MLDS_Module, TypeQualKind, TypeName),
% Figure out whether this type has constructors both with and without
% secondary tags. If so, then the secondary tag field is in a class
% "tag_type" that is derived from the base class for this type,
% rather than in the base class itself.
module_info_get_type_table(ModuleInfo, TypeTable),
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
(
TypeDefnBody = hlds_du_type(type_body_du(_, _, _, _, MaybeRepn, _)),
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
;
MaybeRepn = yes(Repn)
),
CtorRepns = Repn ^ dur_ctor_repns,
ctors_with_and_without_secondary_tag(CtorRepns, NumWith, NumWithout),
( if
NumWith > 0,
NumWithout > 0
then
ClassQualifier = mlds_append_class_qualifier_module_qual(
MLDS_Module, TypeName, TypeArity),
ClassQualKind = TypeQualKind,
ClassName = "tag_type",
ClassArity = 0
else
ClassQualifier = MLDS_Module,
ClassQualKind = module_qual,
ClassName = TypeName,
ClassArity = TypeArity
)
;
( TypeDefnBody = hlds_eqv_type(_)
; TypeDefnBody = hlds_foreign_type(_)
; TypeDefnBody = hlds_solver_type(_)
; TypeDefnBody = hlds_abstract_type(_)
),
unexpected($pred, "non-du type")
),
% Put it all together.
QualClassName = qual_class_name(ClassQualifier, ClassQualKind, ClassName),
ClassId = mlds_class_id(QualClassName, ClassArity),
ClassPtrType = mlds_ptr_type(mlds_class_type(ClassId)),
FieldQualifier = mlds_append_class_qualifier(Target, ClassQualifier,
ClassQualKind, ClassName, ClassArity),
QualifiedFieldName =
qual_field_var_name(FieldQualifier, type_qual, fvn_data_tag),
FieldId = ml_field_named(QualifiedFieldName, ClassPtrType).
%---------------------------------------------------------------------------%
ml_bitwise_or_rvals(Rvals) = OrAllRval :-
(
Rvals = [],
OrAllRval = ml_const(mlconst_int(0))
;
Rvals = [HeadRval | TailRvals],
OrAllRval = ml_bitwise_or_some_rvals(HeadRval, TailRvals)
).
ml_bitwise_or_some_rvals(HeadRval, TailRvals) = OrAllRval :-
% We currently do this a linear fashion, starting at the rightmost
% arguments, and moving towards the left.
%
% We should explore whether other strategies, such as balanced trees,
% (or rather, trees that are as balanced as possible) would work better.
(
TailRvals = [],
OrAllRval = HeadRval
;
TailRvals = [HeadTailRval | TailTailRvals],
TailOrAllRval = ml_bitwise_or_some_rvals(HeadTailRval, TailTailRvals),
OrAllRval = ml_bitwise_or_two_rvals(HeadRval, TailOrAllRval)
).
ml_bitwise_or_two_rvals(RvalA, RvalB) = OrRval :-
some [!MaybeType] (
!:MaybeType = no,
( if RvalA = ml_box(TypeA, UnboxRvalA0) then
UnboxRvalA = UnboxRvalA0,
!:MaybeType = yes(TypeA)
else
UnboxRvalA = RvalA
),
( if RvalB = ml_box(TypeB, UnboxRvalB0) then
UnboxRvalB = UnboxRvalB0,
!:MaybeType = yes(TypeB)
else
UnboxRvalB = RvalB
),
% OR-ing anything with zero has no effect.
( if
( RvalA = ml_const(mlconst_int(0))
; RvalA = ml_const(mlconst_uint(0u))
)
then
UnboxRval = UnboxRvalB
else if
( RvalB = ml_const(mlconst_int(0))
; RvalB = ml_const(mlconst_uint(0u))
)
then
UnboxRval = UnboxRvalA
else
UnboxRval = ml_binop(bitwise_or(int_type_uint),
UnboxRvalA, UnboxRvalB)
),
(
!.MaybeType = yes(BoxType),
OrRval = ml_box(BoxType, UnboxRval)
;
!.MaybeType = no,
OrRval = UnboxRval
)
).
ml_bitwise_mask(Rval, Mask) =
ml_binop(bitwise_and(int_type_uint), Rval, ml_const(mlconst_int(Mask))).
%---------------------------------------------------------------------------%
ml_left_shift_rval(Rval, Shift, Fill) = ShiftedRval :-
Shift = arg_shift(ShiftInt),
ml_cast_to_unsigned_without_sign_extend(Fill, Rval, CastRval),
( if
Rval = ml_const(mlconst_null(_))
then
% We may get nulls from unfilled fields. Replace them with zeroes
% so we don't get type errors from the C compiler.
% The shift amount does not matter, since shifting a zero
% by any amount is a noop.
ShiftedRval = ml_const(mlconst_uint(0u))
else if
(
% Shifting anything by zero bits has no effect.
ShiftInt = 0
;
% Shifting a zero any number of bits has no effect.
Rval = ml_const(Const),
ml_is_zero_const(Const) = ml_is_zero_const
)
then
ShiftedRval = CastRval
else
ShiftedRval =
ml_binop(unchecked_left_shift(int_type_uint, shift_by_int),
CastRval, ml_const(mlconst_int(ShiftInt)))
).
ml_right_shift_rval(Rval, Shift) = ShiftedRval :-
% While ml_lshift may be called on a boxed Rval, ml_rshift will never
% be called that way, which is why we don't handle that as a special case.
Shift = arg_shift(ShiftInt),
% XXX ARG_PACK Should we cast Rval to unsigned like left_shift_rval?
( if
(
% Shifting anything by zero bits has no effect.
ShiftInt = 0
;
% Shifting a zero any number of bits has no effect.
Rval = ml_const(Const),
ml_is_zero_const(Const) = ml_is_zero_const
)
then
ShiftedRval = Rval
else
ShiftedRval =
ml_binop(unchecked_right_shift(int_type_uint, shift_by_int),
Rval, ml_const(mlconst_int(ShiftInt)))
).
%---------------------------------------------------------------------------%
ml_is_zero_const(Const) = IsZero :-
(
Const = mlconst_int(Int),
IsZero =
(if Int = 0 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_uint(Uint),
IsZero =
(if Uint = 0u then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_int8(Int8),
IsZero =
(if Int8 = 0i8 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_uint8(Uint8),
IsZero =
(if Uint8 = 0u8 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_int16(Int16),
IsZero =
(if Int16 = 0i16 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_uint16(Uint16),
IsZero =
(if Uint16 = 0u16 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_int32(Int32),
IsZero =
(if Int32 = 0i32 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_uint32(Uint32),
IsZero =
(if Uint32 = 0u32 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_int64(Int64),
IsZero =
(if Int64 = 0i64 then ml_is_zero_const else ml_is_not_zero_const)
;
Const = mlconst_uint64(Uint64),
IsZero =
(if Uint64 = 0u64 then ml_is_zero_const else ml_is_not_zero_const)
;
( Const = mlconst_null(_)
% For the purposes of bit manipulation, null pointers are *not* zero,
% because they need to be replaced by an int before they can take part
% in bitwise operations.
; Const = mlconst_true
; Const = mlconst_false
; Const = mlconst_enum(_, _)
; Const = mlconst_foreign(_, _, _)
; Const = mlconst_named_const(_, _)
; Const = mlconst_float(_)
; Const = mlconst_char(_)
; Const = mlconst_string(_)
; Const = mlconst_multi_string(_)
; Const = mlconst_data_addr_global_var(_, _)
; Const = mlconst_data_addr_local_var(_)
; Const = mlconst_data_addr_rtti(_, _)
; Const = mlconst_data_addr_tabling(_, _)
; Const = mlconst_code_addr(_)
),
IsZero = ml_is_not_zero_const
).
%---------------------------------------------------------------------------%
% If a sub-word-sized signed integer has a negative value, then it will
% have sign-extend bits *beyond* its usual size. OR-ing the raw form
% of that sub-word-sized signed integer with the values of the other fields
% may thus stomp all over the bits assigned to store the other fields
% that are to the left of the sub-word-sized signed integer.
%
% Prevent this by casting sub-word-sized signed integers to their
% unsigned counterparts before casting them to the word-sized unsigned type
% that is the usual input type of shift and OR operations.
%
:- pred ml_cast_to_unsigned_without_sign_extend(fill_kind::in,
mlds_rval::in, mlds_rval::out) is det.
ml_cast_to_unsigned_without_sign_extend(Fill, Rval0, Rval) :-
(
Fill = fill_enum,
% If we can (because the value to be cast is a constant),
% make it unnecessary to add an explicit cast below.
( if Rval0 = ml_const(mlconst_enum(EnumInt, _Type)) then
EnumUint = uint.det_from_int(EnumInt),
Rval1 = ml_const(mlconst_uint(EnumUint))
else
Rval1 = Rval0
)
;
( Fill = fill_uint8
; Fill = fill_uint16
; Fill = fill_uint32
; Fill = fill_char21
),
Rval1 = Rval0
;
(
Fill = fill_int8,
ToMLDSType = mlds_builtin_type_int(int_type_uint8)
;
Fill = fill_int16,
ToMLDSType = mlds_builtin_type_int(int_type_uint16)
;
Fill = fill_int32,
ToMLDSType = mlds_builtin_type_int(int_type_uint32)
),
Rval1 = ml_cast(ToMLDSType, Rval0)
),
( if
% Don't cast Rval1 to unsigned if it is *already* of that type.
% Of course, other kinds of rvals may also be known to be unsigned,
% but these two patterns cover the rvals that our callers give us.
(
% Unsigned constants are unsigned.
Rval1 = ml_const(mlconst_uint(_))
;
% Shifted unsigned constants are also unsigned.
Rval1 = ml_binop(Binop, ml_const(mlconst_uint(_)), _),
( Binop = unchecked_left_shift(int_type_uint, _)
; Binop = unchecked_right_shift(int_type_uint, _)
)
)
then
Rval = Rval1
else
Rval = ml_cast(mlds_builtin_type_int(int_type_uint), Rval1)
).
%---------------------------------------------------------------------------%
ml_compute_assign_direction(ModuleInfo, NonLocals, ArgVar, ArgVarEntry,
FieldType, ArgMode, Dir) :-
ArgVarType = ArgVarEntry ^ vte_type,
% XXX ARG_PACK We should not need to check here whether
% FieldType is a dummy type; the arg_pos_width should tell us that.
% Computing FieldType is expensive for our callers.
EitherIsDummy = is_either_type_a_dummy(ModuleInfo, FieldType, ArgVarType),
(
EitherIsDummy = at_least_one_is_dummy_type,
Dir = assign_dummy
;
EitherIsDummy = neither_is_dummy_type,
% The rest of the code in this predicate is the same as
% the code of compute_assign_direction, with one exception
% that prevents any simple kind of code reuse: the fact that
% we return assign_nondummy_X instead of assign_X.
%
% Any change here will require a corresponding change there.
ArgMode = unify_modes_li_lf_ri_rf(LeftInitInst, LeftFinalInst,
RightInitInst, RightFinalInst),
init_final_insts_to_top_functor_mode(ModuleInfo,
LeftInitInst, LeftFinalInst, ArgVarType, LeftTopMode),
init_final_insts_to_top_functor_mode(ModuleInfo,
RightInitInst, RightFinalInst, ArgVarType, RightTopMode),
(
LeftTopMode = top_in,
(
RightTopMode = top_in,
% Both input: it is a test unification.
% This shouldn't happen, since mode analysis should avoid
% creating any tests in the arguments of a construction
% or deconstruction unification.
unexpected($pred, "test in arg of [de]construction")
;
RightTopMode = top_out,
% Input - output: it is an assignment to the RHS.
% Is the RHS variable used anywhere else?
( if set_of_var.contains(NonLocals, ArgVar) then
% Yes it is.
Dir = assign_nondummy_right
else
% No, it is not. Our caller therefore will NOT need
% to assign a value to the RHS variable.
Dir = assign_nondummy_unused
)
;
RightTopMode = top_unused,
unexpected($pred, "some strange unify")
)
;
LeftTopMode = top_out,
(
RightTopMode = top_in,
% Output - input: it is an assignment to the LHS.
Dir = assign_nondummy_left
;
( RightTopMode = top_out
; RightTopMode = top_unused
),
unexpected($pred, "some strange unify")
)
;
LeftTopMode = top_unused,
(
RightTopMode = top_unused,
% Unused - unused: the unification has no effect.
Dir = assign_nondummy_unused
;
( RightTopMode = top_in
; RightTopMode = top_out
),
unexpected($pred, "some strange unify")
)
)
).
%---------------------------------------------------------------------------%
local_primsectag_filled_bitfield(Info, LocalArgsTagInfo, FilledBitfield) :-
(
LocalArgsTagInfo = local_args_only_functor,
PrimSec = 0u,
NumPrimSecBits = 0
;
LocalArgsTagInfo = local_args_not_only_functor(_Ptag, LocalSectag),
LocalSectag = local_sectag(_Sectag, PrimSec, SectagBits),
ml_gen_info_get_num_ptag_bits(Info, NumPtagsBitsUint8),
SectagBits = sectag_bits(SectagNumBitsUint8, _SectagMaskUint),
NumPrimSecBits =
uint8.cast_to_int(NumPtagsBitsUint8 + SectagNumBitsUint8)
),
ArgNumBits = arg_num_bits(NumPrimSecBits),
Bitfield = bitfield(arg_shift(0), ArgNumBits, fill_enum),
BitfieldValue = bv_const(PrimSec),
FilledBitfield = filled_bitfield(Bitfield, BitfieldValue).
remote_sectag_filled_bitfield(SectagUint, SectagBits, FilledBitfield) :-
SectagBits = sectag_bits(SectagNumBitsUint8, _SectagMaskUint),
ArgNumBits = arg_num_bits(uint8.cast_to_int(SectagNumBitsUint8)),
Bitfield = bitfield(arg_shift(0), ArgNumBits, fill_enum),
BitfieldValue = bv_const(SectagUint),
FilledBitfield = filled_bitfield(Bitfield, BitfieldValue).
%---------------------------------------------------------------------------%
:- end_module ml_backend.ml_unify_gen_util.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink