mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-16 09:53:36 +00:00
Code Issues Projects Releases Wiki Activity
Files
b357a3dadcdf29c8d8ca184d65f7634a1a94de36
mercury/compiler/rtti_to_mlds.m
Zoltan Somogyi b6ec42a132 Make some arities into pred_form_arities. 
compiler/hlds_pred.m:
    Replace the arity field in pred_infos with a pred_form_arity field.

    Move the pred_info's pred_or_func field to its usual position
    in predicate/function descriptions: at the front (pred/func name/arity).

compiler/hlds_pred.m:
    Change two utility operations to return pred_form_arities instead of
    just arities, since they get them from pred_infos.

compiler/inst_mode_type_prop.m:
compiler/llds.m:
compiler/rtti.m:
    Change some fields whose types used to be arity (or int) to be
    pred_form_arity.

    In llds.m, include a pred_or_func field in c_procedures,
    for use in procedure-start comments.

mdbcomp/prim_data.m:
mdbcomp/program_representation.m:
    Add notes about two possible future improvements along similar lines.

compiler/prog_data.m:
    Add a utility function to calculate the number of extra arguments
    added to predicates/functions by compiler passes such as polymorphism.

compiler/add_pragma.m:
    Conform to the changes above.

    Fix a bug in an error message about ":- external" pragmas:
    the message used the pred_form arity instead of the user arity.
    (See the diff to external2.err_exp below.)

compiler/hlds_defns.m:
    Conform to the changes above.

    Include pred/func prefixes before name/arity pairs in the output
    where relavnt. (The user guide does not need to be updated, because
    its wording permits both the old and the new behavior.)

    Fix two separate bugs that referred to functions in user-facing output
    with the predicate form of their arity.

compiler/table_gen.m:
compiler/unused_args.m:
    Conform to the changes above.

    Fix a bug in each module that referred to functions in user-facing output
    with the predicate form of their arity.

compiler/recompilation.usage.m:
compiler/xml_documentation.m:
    Conform to the changes above.

    Mark a probable bug in each module with an XXX.

compiler/direct_arg_in_out.m:
    Conform to the changes above.

    Improve the wording of an error message a bit.
    (See the diff to gh72_errors.err_exp below.)

compiler/accumulator.m:
compiler/bytecode_gen.m:
compiler/complexity.m:
compiler/default_func_mode.m:
compiler/det_report.m:
compiler/distance_granularity.m:
compiler/equiv_type_hlds.m:
compiler/exception_analysis.m:
compiler/higher_order.m:
compiler/hlds_defns.m:
compiler/hlds_error_util.m:
compiler/hlds_module.m:
compiler/intermod.m:
compiler/intermod_order_pred_info.m:
compiler/introduce_exists_casts.m:
compiler/introduce_parallelism.m:
compiler/llds_out_file.m:
compiler/mercury_compile_llds_back_end.m:
compiler/ml_accurate_gc.m:
compiler/ml_args_util.m:
compiler/mode_errors.m:
compiler/modecheck_util.m:
compiler/modes.m:
compiler/old_type_constraints.m:
compiler/optimize.m:
compiler/polymorphism.m:
compiler/polymorphism_goal.m:
compiler/post_typecheck.m:
compiler/pre_typecheck.m:
compiler/pred_table.m:
compiler/proc_gen.m:
compiler/rbmm.region_transformation.m:
compiler/recompilation.usage.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
compiler/simplify_goal_call.m:
compiler/ssdebug.m:
compiler/table_gen.m:
compiler/tabling_analysis.m:
compiler/term_constr_initial.m:
compiler/termination.m:
compiler/trailing_analysis.m:
compiler/transform_llds.m:
compiler/tupling.m:
compiler/type_class_info.m:
compiler/typecheck.m:
compiler/typecheck_error_undef.m:
compiler/types_into_modes.m:
compiler/xml_documentation.m:
    Conform to the changes above.

compiler/recompilation.m:
    Add a note.

compiler/parse_tree_out_sym_name.m:
    Improve variable names.

tests/invalid/external2.err_exp:
    Expect the fixed arity in an error message.

tests/invalid/gh72_errors.err_exp:
    Expect the expanded text of an error message.
2023-07-03 01:57:10 +02:00

1905 lines
79 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2001-2012 The University of Melbourne.
% Copyright (C) 2014-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: rtti_to_mlds.m.
% Authors: fjh, zs.
%
% This module defines routines to convert from the back-end-independent
% RTTI data structures into MLDS definitions.
% The RTTI data structures are used for static data that is used
% for handling RTTI, polymorphism, and typeclasses.
%
%-----------------------------------------------------------------------------%
:- module ml_backend.rtti_to_mlds.
:- interface.
:- import_module backend_libs.
:- import_module backend_libs.rtti.
:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.mlds.
:- import_module list.
%-----------------------------------------------------------------------------%
% Add the MLDS definitions for the given rtti_data(s) to the
% ml_global_data structure.
%
:- pred add_rtti_datas_to_mlds(module_info::in, mlds_target_lang::in,
list(rtti_data)::in, ml_global_data::in, ml_global_data::out) is det.
:- pred add_rtti_data_to_mlds(module_info::in, mlds_target_lang::in,
rtti_data::in, ml_global_data::in, ml_global_data::out) is det.
% Given a list of MLDS RTTI data definitions, return the definitions
% such that if X appears in the initialiser for Y then X appears earlier in
% the list than Y.
%
% This function returns a list of cliques so that problems with ordering
% within cliques, if any, may be easier to discover.
%
:- func order_mlds_rtti_defns(list(mlds_global_var_defn)) =
list(list(mlds_global_var_defn)).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.type_ctor_info.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module libs.
:- import_module libs.globals.
:- import_module mdbcomp.
:- import_module mdbcomp.builtin_modules.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module ml_backend.ml_args_util.
:- import_module ml_backend.ml_closure_gen.
:- import_module ml_backend.ml_code_util.
:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.ml_util.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module assoc_list.
:- import_module bool.
:- import_module counter.
:- import_module digraph.
:- import_module int16.
:- import_module int32.
:- import_module int8.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module term_context.
:- import_module uint.
:- import_module uint16.
:- import_module uint32.
:- import_module uint8.
:- import_module univ.
%-----------------------------------------------------------------------------%
add_rtti_datas_to_mlds(ModuleInfo, Target, RttiDatas, !GlobalData) :-
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RttiDatas, !GlobalData).
add_rtti_data_to_mlds(ModuleInfo, Target, RttiData, !GlobalData) :-
( if RttiData = rtti_data_pseudo_type_info(type_var(_)) then
% These just get represented as integers, so we don't need to define
% a structure for them; which is why rtti_data_to_id/3 does not
% handle this case.
true
else
gen_init_rtti_data_defn(ModuleInfo, Target, RttiData, !GlobalData)
).
:- pred rtti_name_and_init_to_defn(rtti_type_ctor::in, ctor_rtti_name::in,
mlds_initializer::in, ml_global_data::in, ml_global_data::out) is det.
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer, !GlobalData) :-
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred rtti_id_and_init_to_defn(rtti_id::in, mlds_initializer::in,
ml_global_data::in, ml_global_data::out) is det.
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData) :-
Name = gvn_rtti_var(RttiId),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
:- pred rtti_entity_name_and_init_to_defn(mlds_global_var_name::in,
rtti_id::in, mlds_initializer::in,
ml_global_data::in, ml_global_data::out) is det.
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData) :-
% Generate the context.
%
% XXX The rtti_data ought to include a prog_context (the context of the
% corresponding type or instance definition).
Context = dummy_context,
% Generate the declaration flags.
Exported = rtti_id_is_exported(RttiId),
(
Exported = no,
Access = gvar_acc_module_only
;
Exported = yes,
Access = gvar_acc_whole_program
),
Flags = rtti_data_decl_flags(Access),
% The GC never needs to trace these definitions, because they are static
% constants, and can point only to other static constants, not to the heap.
GCStatement = gc_no_stmt,
% Generate the declaration body, i.e. the type and the initializer.
MLDS_Type = mlds_rtti_type(item_type(RttiId)),
DataDefn = mlds_global_var_defn(Name, Context, Flags, MLDS_Type,
Initializer, GCStatement),
ml_global_data_add_rtti_defn(DataDefn, !GlobalData).
% Return the declaration flags appropriate for an rtti_data.
%
:- func rtti_data_decl_flags(global_var_access) = mlds_global_var_decl_flags.
rtti_data_decl_flags(Access) = mlds_global_var_decl_flags(Access, const).
%-----------------------------------------------------------------------------%
% Return an MLDS initializer for the given RTTI definition
% occurring in the given module.
%
:- pred gen_init_rtti_data_defn(module_info::in, mlds_target_lang::in,
rtti_data::in, ml_global_data::in, ml_global_data::out) is det.
gen_init_rtti_data_defn(ModuleInfo, Target, RttiData, !GlobalData) :-
rtti_data_to_id(RttiData, RttiId),
Name = gvn_rtti_var(RttiId),
(
RttiData = rtti_data_base_typeclass_info(_InstanceModule, _ClassId,
_InstanceStr, BaseTypeClassInfo),
BaseTypeClassInfo = base_typeclass_info(N1, N2, N3, N4, N5, Methods),
NumExtra = BaseTypeClassInfo ^ num_extra,
list.map_foldl(gen_init_method(ModuleInfo, Target, NumExtra),
Methods, MethodInitializers, !GlobalData),
Initializer = init_array([
gen_init_boxed_int(N1),
gen_init_boxed_int(N2),
gen_init_boxed_int(N3),
gen_init_boxed_int(N4),
gen_init_boxed_int(N5)
| MethodInitializers
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData)
;
RttiData = rtti_data_type_info(TypeInfo),
gen_type_info_defn(ModuleInfo, Target, TypeInfo, Name,
RttiId, !GlobalData)
;
RttiData = rtti_data_pseudo_type_info(PseudoTypeInfo),
gen_pseudo_type_info_defn(ModuleInfo, Target, PseudoTypeInfo, Name,
RttiId, !GlobalData)
;
RttiData = rtti_data_type_class_decl(TCDecl),
gen_type_class_decl_defn(ModuleInfo, Target, TCDecl, Name,
RttiId, !GlobalData)
;
RttiData = rtti_data_type_class_instance(Instance),
gen_type_class_instance_defn(ModuleInfo, Target, Instance, Name,
RttiId, !GlobalData)
;
RttiData = rtti_data_type_ctor_info(TypeCtorData),
TypeCtorData = type_ctor_data(Version, TypeModule, TypeName,
TypeArity, UnifyUniv, CompareUniv, Flags, TypeCtorDetails),
RttiTypeCtor = rtti_type_ctor(TypeModule, TypeName, TypeArity),
TypeModuleName = sym_name_to_string(TypeModule),
MaybeNumPtags = type_ctor_details_num_ptags(TypeCtorDetails),
(
MaybeNumPtags = yes(NumPtags),
NumPtagsEncoding = int8.det_from_int(NumPtags)
;
MaybeNumPtags = no,
NumPtagsEncoding = -1i8
),
MaybeNumFunctors = type_ctor_details_num_functors(TypeCtorDetails),
(
MaybeNumFunctors = yes(NumFunctors),
NumFunctorsEncoding = NumFunctors
;
MaybeNumFunctors = no,
NumFunctorsEncoding = -1
),
FunctorsRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_functors),
LayoutRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_layout),
gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor,
TypeCtorDetails, FunctorsInfo, LayoutInfo, NumberMapInfo,
BaseTypeCtorInitializer, !GlobalData),
% Note that gen_init_special_pred will by necessity add an extra
% level of indirection to calling the special preds. However, the
% backend compiler should be smart enough to ensure that this is
% inlined away.
gen_init_special_pred(ModuleInfo, Target,
UnifyUniv, UnifyInitializer, !GlobalData),
gen_init_special_pred(ModuleInfo, Target,
CompareUniv, CompareInitializer, !GlobalData),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_type_ctor_arity -- XXX MAKE_FIELD_UNSIGNED
gen_init_int(uint16.to_int(TypeArity)),
% MR_type_ctor_version
gen_init_uint8(Version),
% MR_type_ctor_num_ptags
gen_init_int8(NumPtagsEncoding),
% MR_type_ctor_rep_CAST_ME
gen_init_type_ctor_rep(TypeCtorData),
% MR_type_ctor_unify_pred
UnifyInitializer,
% MR_type_ctor_compare_pred
CompareInitializer,
% MR_type_ctor_module_name
gen_init_string(TypeModuleName),
% MR_type_ctor_name
gen_init_string(TypeName),
% In the C back-end, these two "structs" are actually unions.
% We need to use `init_struct' here so that the initializers
% get enclosed in curly braces.
% MR_type_ctor_functors
init_struct(mlds_rtti_type(item_type(FunctorsRttiId)), [
FunctorsInfo
]),
% MR_type_ctor_layout
init_struct(mlds_rtti_type(item_type(LayoutRttiId)), [
LayoutInfo
]),
% MR_type_ctor_num_functors
gen_init_int(NumFunctorsEncoding),
% MR_type_ctor_flags
gen_init_uint16(encode_type_ctor_flags(Flags)),
% MR_type_ctor_functor_number_map
NumberMapInfo,
% MR_type_ctor_base
BaseTypeCtorInitializer
% These two are commented out while the corresponding fields of the
% MR_TypeCtorInfo_Struct type are commented out.
% gen_init_maybe(gen_init_rtti_name(RttiTypeCtor), MaybeHashCons),
% XXX this may need to change to call
% gen_init_special_pred, if this is re-enabled.
% gen_init_proc_id_from_univ(ModuleInfo, PrettyprinterProc)
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData)
).
%-----------------------------------------------------------------------------%
:- pred gen_type_class_decl_defn(module_info::in, mlds_target_lang::in,
tc_decl::in, mlds_global_var_name::in, rtti_id::in,
ml_global_data::in, ml_global_data::out) is det.
gen_type_class_decl_defn(ModuleInfo, Target, TCDecl, Name, RttiId,
!GlobalData) :-
TCDecl = tc_decl(TCId, Version, Supers),
TCId = tc_id(TCName, TVarNames, MethodIds),
TCName = tc_name(ModuleSymName, ClassName, Arity),
module_info_get_name(ModuleInfo, ModuleName),
TVarNamesRttiId = tc_rtti_id(TCName, type_class_id_var_names),
(
TVarNames = [],
TVarNamesInitType = mlds_rtti_type(item_type(TVarNamesRttiId)),
TVarNamesInitializer = gen_init_null_pointer(TVarNamesInitType)
;
TVarNames = [_ | _],
gen_tc_id_var_names(TVarNamesRttiId, TVarNames, !GlobalData),
TVarNamesInitializer = gen_init_rtti_id(ModuleName, TVarNamesRttiId)
),
MethodIdsRttiId = tc_rtti_id(TCName, type_class_id_method_ids),
(
MethodIds = [],
MethodIdsInitType = mlds_rtti_type(item_type(MethodIdsRttiId)),
MethodIdsInitializer = gen_init_null_pointer(MethodIdsInitType)
;
MethodIds = [_ | _],
gen_tc_id_method_ids(MethodIdsRttiId, TCName, MethodIds, !GlobalData),
MethodIdsInitializer = gen_init_rtti_id(ModuleName, MethodIdsRttiId)
),
TCIdRttiId = tc_rtti_id(TCName, type_class_id),
ModuleSymNameStr = sym_name_to_string(ModuleSymName),
list.length(TVarNames, NumTVars),
list.length(MethodIds, NumMethods),
TCIdInitializer = init_struct(mlds_rtti_type(item_type(TCIdRttiId)), [
gen_init_string(ModuleSymNameStr),
gen_init_string(ClassName),
gen_init_int(Arity),
gen_init_int(NumTVars),
gen_init_int(NumMethods),
TVarNamesInitializer,
MethodIdsInitializer
]),
rtti_id_and_init_to_defn(TCIdRttiId, TCIdInitializer, !GlobalData),
(
Supers = []
;
Supers = [_ | _],
list.map_foldl2(
gen_tc_constraint(ModuleInfo, Target, make_decl_super_id(TCName)),
Supers, SuperRttiIds, counter.init(1), _, !GlobalData),
SuperArrayRttiName = type_class_decl_supers,
SuperArrayRttiId = tc_rtti_id(TCName, SuperArrayRttiName),
ElementType = mlds_rtti_type(element_type(SuperArrayRttiId)),
SuperArrayInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), SuperRttiIds),
rtti_id_and_init_to_defn(SuperArrayRttiId, SuperArrayInitializer,
!GlobalData)
),
% XXX Is MethodIdsRttiId the right thing to take the type from?
SupersInitType = mlds_rtti_type(item_type(MethodIdsRttiId)),
SupersInitializer = gen_init_null_pointer(SupersInitType),
list.length(Supers, NumSupers),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_id(ModuleName, TCIdRttiId),
gen_init_int(Version),
gen_init_int(NumSupers),
SupersInitializer
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
:- pred make_decl_super_id(tc_name::in, int::in, int::in, rtti_id::out) is det.
make_decl_super_id(TCName, TCNum, Arity, RttiId) :-
TCRttiName = type_class_decl_super(TCNum, Arity),
RttiId = tc_rtti_id(TCName, TCRttiName).
:- pred gen_tc_id_var_names(rtti_id::in, list(string)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_tc_id_var_names(RttiId, Names, !GlobalData) :-
Initializer = gen_init_array(gen_init_string, Names),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_tc_id_method_ids(rtti_id::in, tc_name::in, list(tc_method_id)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_tc_id_method_ids(RttiId, TCName, MethodIds, !GlobalData) :-
Initializer = gen_init_array(gen_tc_id_method_id(TCName), MethodIds),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- func gen_tc_id_method_id(tc_name, tc_method_id) = mlds_initializer.
gen_tc_id_method_id(TCName, MethodId) = Initializer :-
MethodId =
tc_method_id(MethodName, pred_form_arity(MethodArity), PredOrFunc),
RttiId = tc_rtti_id(TCName, type_class_id_method_ids),
Initializer = init_struct(mlds_rtti_type(element_type(RttiId)), [
gen_init_string(MethodName),
gen_init_int(MethodArity),
gen_init_pred_or_func(PredOrFunc)
]).
%-----------------------------------------------------------------------------%
:- pred gen_type_class_instance_defn(module_info::in, mlds_target_lang::in,
tc_instance::in, mlds_global_var_name::in, rtti_id::in,
ml_global_data::in, ml_global_data::out) is det.
gen_type_class_instance_defn(ModuleInfo, Target, Instance, Name, RttiId,
!GlobalData) :-
Instance = tc_instance(TCName, Types, NumTypeVars,
InstanceConstraints, _Methods),
TCDeclRttiId = tc_rtti_id(TCName, type_class_decl),
list.length(InstanceConstraints, NumInstanceConstraints),
InstanceTypesTCRttiName = type_class_instance_tc_type_vector(Types),
InstanceTypesRttiId = tc_rtti_id(TCName, InstanceTypesTCRttiName),
InstanceConstrsTCRttiName = type_class_instance_constraints(Types),
InstanceConstrsRttiId = tc_rtti_id(TCName, InstanceConstrsTCRttiName),
module_info_get_name(ModuleInfo, ModuleName),
TypeRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, Types),
gen_pseudo_type_info_array(ModuleInfo, Target, TypeRttiDatas,
TypesInitializer, !GlobalData),
rtti_id_and_init_to_defn(InstanceTypesRttiId, TypesInitializer,
!GlobalData),
list.map_foldl2(
gen_tc_constraint(ModuleInfo, Target,
make_instance_constr_id(TCName, Types)),
InstanceConstraints, TCConstrIds, counter.init(1), _, !GlobalData),
ElementType = mlds_rtti_type(element_type(InstanceConstrsRttiId)),
InstanceConstrsInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), TCConstrIds),
rtti_id_and_init_to_defn(InstanceConstrsRttiId, InstanceConstrsInitializer,
!GlobalData),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_id(ModuleName, TCDeclRttiId),
gen_init_int(NumTypeVars),
gen_init_int(NumInstanceConstraints),
gen_init_rtti_id(ModuleName, InstanceTypesRttiId),
gen_init_rtti_id(ModuleName, InstanceConstrsRttiId)
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer, !GlobalData).
:- pred make_instance_constr_id(tc_name::in, list(tc_type)::in,
int::in, int::in, rtti_id::out) is det.
make_instance_constr_id(TCName, Types, TCNum, Arity, RttiId) :-
RttiName = type_class_instance_constraint(Types, TCNum, Arity),
RttiId = tc_rtti_id(TCName, RttiName).
%-----------------------------------------------------------------------------%
:- pred gen_type_info_defn(module_info::in, mlds_target_lang::in,
rtti_type_info::in, mlds_global_var_name::in, rtti_id::in,
ml_global_data::in, ml_global_data::out) is det.
gen_type_info_defn(ModuleInfo, Target, RttiTypeInfo, Name, RttiId,
!GlobalData) :-
(
RttiTypeInfo = plain_arity_zero_type_info(_),
unexpected($pred, "plain_arity_zero_type_info")
;
RttiTypeInfo = plain_type_info(RttiTypeCtor, ArgTypes),
ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
( if map.search(PDupRvalTypeMap, RttiId, _) then
% We have already generated the required global data structures.
true
else
ArgRttiDatas = list.map(type_info_to_rtti_data, ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RealRttiDatas, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_cast_rtti_datas_array(mlds_type_info_type,
ModuleName, ArgRttiDatas)
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)),
Type = mlds_rtti_type(item_type(RttiId)),
RvalType = ml_rval_and_type(Rval, Type),
ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
)
;
RttiTypeInfo = var_arity_type_info(VarArityId, ArgTypes),
ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
( if map.search(PDupRvalTypeMap, RttiId, _) then
% We have already generated the required global data structures.
true
else
ArgRttiDatas = list.map(type_info_to_rtti_data, ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RealRttiDatas, !GlobalData),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(VarArityId),
module_info_get_name(ModuleInfo, ModuleName),
InitRttiName = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
InitCastRttiDatasArray = gen_init_cast_rtti_datas_array(
mlds_type_info_type, ModuleName, ArgRttiDatas),
(
Target = ml_target_java,
% For Java we need to omit the arity argument as the
% TypeInfo_Struct class doesn't have a constructor that
% supports it -- see java/runtime/TypeInfo_Struct.java for
% details.
%
% NOTE: this needs to be kept consistent with
%
% polymorphism.polymorphism_construct_type_info/10
% java/runtime/TypeInfo_Struct.java
%
% as well as the code for handling pseudo type-infos below.
%
InitializerArgs = [InitRttiName, InitCastRttiDatasArray]
;
( Target = ml_target_c
; Target = ml_target_csharp
),
InitializerArgs = [
InitRttiName,
gen_init_int(list.length(ArgTypes)),
InitCastRttiDatasArray]
),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)),
InitializerArgs),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)),
Type = mlds_rtti_type(item_type(RttiId)),
RvalType = ml_rval_and_type(Rval, Type),
ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
)
).
:- pred gen_pseudo_type_info_defn(module_info::in, mlds_target_lang::in,
rtti_pseudo_type_info::in, mlds_global_var_name::in, rtti_id::in,
ml_global_data::in, ml_global_data::out) is det.
gen_pseudo_type_info_defn(ModuleInfo, Target, RttiPseudoTypeInfo, Name, RttiId,
!GlobalData) :-
(
RttiPseudoTypeInfo = plain_arity_zero_pseudo_type_info(_),
unexpected($pred, "plain_arity_zero_pseudo_type_info")
;
RttiPseudoTypeInfo = plain_pseudo_type_info(RttiTypeCtor, ArgTypes),
ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
( if map.search(PDupRvalTypeMap, RttiId, _) then
% We have already generated the required global data structures.
true
else
ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data,
ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RealRttiDatas, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
ModuleName, ArgRttiDatas)
]),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)),
Type = mlds_rtti_type(item_type(RttiId)),
RvalType = ml_rval_and_type(Rval, Type),
ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
)
;
RttiPseudoTypeInfo = var_arity_pseudo_type_info(VarArityId, ArgTypes),
ml_global_data_get_pdup_rval_type_map(!.GlobalData, PDupRvalTypeMap),
( if map.search(PDupRvalTypeMap, RttiId, _) then
% We have already generated the required global data structures.
true
else
ArgRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data,
ArgTypes),
RealRttiDatas = list.filter(real_rtti_data, ArgRttiDatas),
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RealRttiDatas, !GlobalData),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(VarArityId),
module_info_get_name(ModuleInfo, ModuleName),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, TargetLang),
InitRttiName = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_type_ctor_info),
InitCastRttiDatasArray = gen_init_cast_rtti_datas_array(
mlds_pseudo_type_info_type, ModuleName, ArgRttiDatas),
( if TargetLang = target_java then
% For Java we need to omit the arity argument as the
% TypeInfo_Struct class doesn't have a constructor that
% supports it. The TypeInfo_Struct class is used to represent
% pseudo type-infos with the Java backend.
% (See java/runtime/PseudoTypeInfo.java for details.)
InitializerArgs = [InitRttiName, InitCastRttiDatasArray]
else
InitializerArgs = [
InitRttiName,
gen_init_int(list.length(ArgTypes)),
InitCastRttiDatasArray
]
),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)),
InitializerArgs),
rtti_entity_name_and_init_to_defn(Name, RttiId, Initializer,
!GlobalData),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)),
Type = mlds_rtti_type(item_type(RttiId)),
RvalType = ml_rval_and_type(Rval, Type),
ml_global_data_add_pdup_rtti_id(RttiId, RvalType, !GlobalData)
)
;
RttiPseudoTypeInfo = type_var(_),
unexpected($pred, "type_var")
).
%-----------------------------------------------------------------------------%
:- pred gen_functors_layout_info(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, type_ctor_details::in,
mlds_initializer::out, mlds_initializer::out, mlds_initializer::out,
mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
FunctorInitializer, LayoutInitializer, NumberMapInitializer,
BaseTypeCtorInitializer, !GlobalData) :-
module_info_get_name(ModuleInfo, ModuleName),
(
TypeCtorDetails = tcd_enum(_, _IsDummy, EnumFunctors,
EnumByOrd, EnumByName, FunctorNumberMap, MaybeBaseTypeCtor),
list.foldl(gen_enum_functor_desc(ModuleInfo, RttiTypeCtor),
EnumFunctors, !GlobalData),
gen_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
EnumByOrd, !GlobalData),
gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
EnumByName, !GlobalData),
gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_ordinal_ordered_table),
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
MaybeBaseTypeCtor)
;
TypeCtorDetails = tcd_foreign_enum(ForeignEnumLang, _,
ForeignEnumFunctors, ForeignEnumByOrdinal, ForeignEnumByName,
FunctorNumberMap),
list.foldl(
gen_foreign_enum_functor_desc(ModuleInfo, ForeignEnumLang,
RttiTypeCtor),
ForeignEnumFunctors, !GlobalData),
gen_foreign_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
ForeignEnumByOrdinal, !GlobalData),
gen_foreign_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
ForeignEnumByName, !GlobalData),
gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_foreign_enum_ordinal_ordered_table),
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_foreign_enum_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
no)
;
TypeCtorDetails = tcd_du(_, DuFunctors, DuByPtag, DuByName,
FunctorNumberMap, MaybeBaseTypeCtor),
list.foldl(gen_du_functor_desc(ModuleInfo, Target, RttiTypeCtor),
DuFunctors, !GlobalData),
gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor,
DuByPtag, !GlobalData),
gen_du_name_ordered_table(ModuleInfo, RttiTypeCtor,
DuByName, !GlobalData),
gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_ptag_ordered_table),
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
MaybeBaseTypeCtor)
;
TypeCtorDetails = tcd_notag(_, NotagFunctor, MaybeBaseTypeCtor),
gen_functor_number_map(RttiTypeCtor, [0u32], !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
gen_notag_functor_desc(ModuleInfo, Target, RttiTypeCtor, NotagFunctor,
!GlobalData),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
MaybeBaseTypeCtor)
;
TypeCtorDetails = tcd_eqv(EqvType),
TypeRttiData = maybe_pseudo_type_info_to_rtti_data(EqvType),
gen_pseudo_type_info(ModuleInfo, Target, TypeRttiData,
LayoutInitializer, !GlobalData),
% The type is a lie, but a safe one.
FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
NumberMapInitializer = gen_init_null_pointer(mlds_generic_type),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
no)
;
( TypeCtorDetails = tcd_builtin(_)
; TypeCtorDetails = tcd_impl_artifact(_)
; TypeCtorDetails = tcd_foreign(_)
),
LayoutInitializer = gen_init_null_pointer(mlds_generic_type),
FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
NumberMapInitializer = gen_init_null_pointer(mlds_generic_type),
BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
no)
).
%-----------------------------------------------------------------------------%
:- pred gen_enum_functor_desc(module_info::in, rtti_type_ctor::in,
enum_functor::in, ml_global_data::in, ml_global_data::out) is det.
gen_enum_functor_desc(_ModuleInfo, RttiTypeCtor, EnumFunctor, !GlobalData) :-
EnumFunctor = enum_functor(FunctorName, Ordinal, enum_value(Value)),
RttiName = type_ctor_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_enum_functor_name
gen_init_string(FunctorName),
% MR_enum_functor_value -- XXX MAKE_FIELD_UNSIGNED
gen_init_int32(int32.cast_from_uint32(Value))
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_foreign_enum_functor_desc(module_info::in, foreign_language::in,
rtti_type_ctor::in, foreign_enum_functor::in,
ml_global_data::in, ml_global_data::out) is det.
gen_foreign_enum_functor_desc(_ModuleInfo, Lang, RttiTypeCtor,
ForeignEnumFunctor, !GlobalData) :-
ForeignEnumFunctor = foreign_enum_functor(FunctorName, Ordinal, Value),
RttiName = type_ctor_foreign_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_foreign_enum_functor_name
gen_init_string(FunctorName),
% MR_foreign_enum_functor_ordinal -- XXX MAKE_FIELD_UNSIGNED
gen_init_int32(int32.cast_from_uint32(Ordinal)),
% MR_foreign_enum_functor_value
gen_init_foreign(Lang, Value)
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_notag_functor_desc(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, notag_functor::in,
ml_global_data::in, ml_global_data::out) is det.
gen_notag_functor_desc(ModuleInfo, Target, RttiTypeCtor, NotagFunctorDesc,
!GlobalData) :-
NotagFunctorDesc = notag_functor(FunctorName, ArgType, MaybeArgName,
FunctorSubtypeInfo),
ArgTypeRttiData = maybe_pseudo_type_info_to_rtti_data(ArgType),
gen_pseudo_type_info(ModuleInfo, Target, ArgTypeRttiData, PTIInitializer,
!GlobalData),
RttiName = type_ctor_notag_functor_desc,
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_notag_functor_name
gen_init_string(FunctorName),
% MR_notag_functor_arg_type
PTIInitializer,
% MR_notag_functor_arg_name
gen_init_maybe(mlds_builtin_type_string, gen_init_string,
MaybeArgName),
% MR_notag_functor_subtype
gen_init_functor_subtype_info(FunctorSubtypeInfo)
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_du_functor_desc(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, du_functor::in,
ml_global_data::in, ml_global_data::out) is det.
gen_du_functor_desc(ModuleInfo, Target, RttiTypeCtor, DuFunctor,
!GlobalData) :-
DuFunctor = du_functor(FunctorName, Arity, Ordinal, Rep, ArgInfos,
MaybeExistInfo, FunctorSubtypeInfo),
ArgTypes = list.map(du_arg_info_type, ArgInfos),
MaybeArgNames = list.map(du_arg_info_name, ArgInfos),
HaveArgNames = (if list.member(yes(_), MaybeArgNames) then yes else no),
ContainsVarBitVector = compute_contains_var_bit_vector(ArgTypes),
module_info_get_name(ModuleInfo, ModuleName),
(
ArgInfos = [_ | _],
gen_field_types(ModuleInfo, Target, RttiTypeCtor, Ordinal, ArgTypes,
!GlobalData),
ArgTypeInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_types(Ordinal))
;
ArgInfos = [],
ArgTypeInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_types(0u32)))))
),
(
HaveArgNames = yes,
gen_field_names(ModuleInfo, RttiTypeCtor, Ordinal,
MaybeArgNames, !GlobalData),
ArgNameInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_names(Ordinal))
;
HaveArgNames = no,
ArgNameInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_names(0u32)))))
),
gen_field_locns(ModuleInfo, RttiTypeCtor, Ordinal, ArgInfos, HaveArgLocns,
!GlobalData),
(
HaveArgLocns = yes,
ArgLocnsInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_field_locns(Ordinal))
;
HaveArgLocns = no,
ArgLocnsInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_field_locns(0u32)))))
),
(
MaybeExistInfo = yes(ExistInfo),
gen_exist_info(ModuleInfo, Target, RttiTypeCtor, Ordinal, ExistInfo,
!GlobalData),
ExistInfoInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_info(Ordinal))
;
MaybeExistInfo = no,
ExistInfoInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(
ctor_rtti_id(RttiTypeCtor, type_ctor_exist_info(0u32)))))
),
(
Rep = du_ll_rep(Ptag, SectagAndLocn),
Ptag = ptag(PtagUint8)
;
Rep = du_hl_rep(Data),
PtagUint8 = 0u8,
SectagAndLocn = sectag_locn_remote_word(Data)
),
(
SectagAndLocn = sectag_locn_none,
Locn = sectag_none,
Stag = -1,
NumSectagBits = 0u8
;
SectagAndLocn = sectag_locn_none_direct_arg,
Locn = sectag_none_direct_arg,
Stag = -1,
NumSectagBits = 0u8
;
SectagAndLocn = sectag_locn_local_rest_of_word(StagUint),
Locn = sectag_local_rest_of_word,
Stag = uint.cast_to_int(StagUint),
NumSectagBits = 0u8
;
SectagAndLocn = sectag_locn_local_bits(StagUint, NumSectagBits, Mask),
Locn = sectag_local_bits(NumSectagBits, Mask),
Stag = uint.cast_to_int(StagUint)
;
SectagAndLocn = sectag_locn_remote_word(StagUint),
Locn = sectag_remote_word,
Stag = uint.cast_to_int(StagUint),
NumSectagBits = 0u8
;
SectagAndLocn = sectag_locn_remote_bits(StagUint, NumSectagBits, Mask),
Locn = sectag_remote_bits(NumSectagBits, Mask),
Stag = uint.cast_to_int(StagUint)
),
RttiName = type_ctor_du_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
ArityInt16 = int16.cast_from_uint16(Arity), % XXX MAKE_FIELD_UNSIGNED
OrdinalInt32 = int32.cast_from_uint32(Ordinal), % XXX MAKE_FIELD_UNSIGNED
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName), % MR_du_functor_name
gen_init_int16(ArityInt16), % MR_du_functor_orig_arity
gen_init_uint16(ContainsVarBitVector),
% MR_du_functor_arg_type_contains_var
gen_init_sectag_locn(Locn), % MR_du_functor_sectag_locn
gen_init_uint8(PtagUint8), % MR_du_functor_primary
gen_init_int(Stag), % MR_du_functor_secondary
gen_init_int32(OrdinalInt32), % MR_du_functor_ordinal
ArgTypeInitializer, % MR_du_functor_arg_types
ArgNameInitializer, % MR_du_functor_arg_names
ArgLocnsInitializer, % MR_du_functor_arg_locns
ExistInfoInitializer, % MR_du_functor_exist_info
gen_init_functor_subtype_info(FunctorSubtypeInfo),
% MR_du_functor_subtype_constraints
gen_init_uint8(NumSectagBits) % MR_du_functor_num_sectag_bits
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
%-----------------------------------------------------------------------------%
:- func gen_init_exist_locn(rtti_type_ctor, exist_typeinfo_locn) =
mlds_initializer.
gen_init_exist_locn(RttiTypeCtor, ExistTypeInfoLocn) = Initializer :-
(
ExistTypeInfoLocn = typeinfo_in_tci(SlotInCell, SlotInTci),
SlotInTciEncoding = int16.cast_from_uint16(SlotInTci)
;
ExistTypeInfoLocn = plain_typeinfo(SlotInCell),
SlotInTciEncoding = -1i16
),
RttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_exist_locn),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_exist_arg_num -- XXX MAKE_FIELD_UNSIGNED
gen_init_int16(int16.cast_from_uint16(SlotInCell)),
% MR_exist_offset_in_tci
gen_init_int16(SlotInTciEncoding)
]).
:- pred gen_exist_locns_array(module_info::in, rtti_type_ctor::in, uint32::in,
list(exist_typeinfo_locn)::in, ml_global_data::in, ml_global_data::out)
is det.
gen_exist_locns_array(_ModuleInfo, RttiTypeCtor, Ordinal, Locns,
!GlobalData) :-
Initializer = gen_init_array(gen_init_exist_locn(RttiTypeCtor), Locns),
RttiName = type_ctor_exist_locns(Ordinal),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_tc_constraint(module_info::in, mlds_target_lang::in,
pred(int, int, rtti_id)::in(pred(in, in, out) is det),
tc_constraint::in, rtti_id::out, counter::in, counter::out,
ml_global_data::in, ml_global_data::out) is det.
gen_tc_constraint(ModuleInfo, Target, MakeRttiId, Constraint, RttiId,
!Counter, !GlobalData) :-
Constraint = tc_constraint(TCName, Types),
list.length(Types, Arity),
counter.allocate(TCNum, !Counter),
MakeRttiId(TCNum, Arity, RttiId),
TCDeclRttiName = type_class_decl,
module_info_get_name(ModuleInfo, ModuleName),
TypeRttiDatas = list.map(maybe_pseudo_type_info_to_rtti_data, Types),
gen_pseudo_type_info_array(ModuleInfo, Target, TypeRttiDatas,
PTIInitializers, !GlobalData),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_tc_rtti_name(ModuleName, TCName, TCDeclRttiName),
PTIInitializers
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred make_exist_tc_constr_id(rtti_type_ctor::in, uint32::in, int::in,
int::in, rtti_id::out) is det.
make_exist_tc_constr_id(RttiTypeCtor, Ordinal, TCNum, Arity, RttiId) :-
RttiName = type_ctor_exist_tc_constr(Ordinal, TCNum, Arity),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName).
:- pred gen_exist_info(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, uint32::in, exist_info::in,
ml_global_data::in, ml_global_data::out) is det.
gen_exist_info(ModuleInfo, Target, RttiTypeCtor, Ordinal, ExistInfo,
!GlobalData) :-
ExistInfo = exist_info(Plain, InTci, Constraints, Locns),
module_info_get_name(ModuleInfo, ModuleName),
RttiName = type_ctor_exist_info(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
list.length(Constraints, Tci),
(
Constraints = [],
ConstrInitializer = gen_init_null_pointer(
mlds_rtti_type(item_type(ctor_rtti_id(RttiTypeCtor,
type_ctor_exist_tc_constrs(Ordinal)))))
;
Constraints = [_ | _],
ConstrInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_tc_constrs(Ordinal)),
list.map_foldl2(
gen_tc_constraint(ModuleInfo, Target,
make_exist_tc_constr_id(RttiTypeCtor, Ordinal)),
Constraints, TCConstrIds, counter.init(1), _, !GlobalData),
TCConstrArrayRttiName = type_ctor_exist_tc_constrs(Ordinal),
TCConstrArrayRttiId = ctor_rtti_id(RttiTypeCtor,
TCConstrArrayRttiName),
ElementType = mlds_rtti_type(element_type(TCConstrArrayRttiId)),
TCConstrArrayInitializer = gen_init_array(
gen_init_cast_rtti_id(ElementType, ModuleName), TCConstrIds),
rtti_name_and_init_to_defn(RttiTypeCtor, TCConstrArrayRttiName,
TCConstrArrayInitializer, !GlobalData)
),
gen_exist_locns_array(ModuleInfo, RttiTypeCtor, Ordinal, Locns,
!GlobalData),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_exist_typeinfos_plain -- XXX MAKE_FIELD_UNSIGNED
gen_init_int16(int16.cast_from_uint16(Plain)),
% MR_exist_typeinfos_in_tci -- XXX MAKE_FIELD_UNSIGNED
gen_init_int16(int16.cast_from_uint16(InTci)),
% MR_exist_tcis -- XXX MAKE_FIELD_UNSIGNED
gen_init_int16(int16.det_from_int(Tci)),
% MR_exist_typeinfo_locns
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_exist_locns(Ordinal)),
% MR_exist_constraints
ConstrInitializer
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
:- pred gen_field_types(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, uint32::in,
list(rtti_maybe_pseudo_type_info_or_self)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_field_types(ModuleInfo, Target, RttiTypeCtor, Ordinal, Types,
!GlobalData) :-
TypeRttiDatas = list.map(maybe_pseudo_type_info_or_self_to_rtti_data,
Types),
gen_pseudo_type_info_array(ModuleInfo, Target, TypeRttiDatas, Initializer,
!GlobalData),
RttiName = type_ctor_field_types(Ordinal),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_field_names(module_info::in, rtti_type_ctor::in, uint32::in,
list(maybe(string))::in, ml_global_data::in, ml_global_data::out) is det.
gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames, !GlobalData) :-
Initializer = gen_init_array(
gen_init_maybe(mlds_builtin_type_string, gen_init_string),
MaybeNames),
RttiName = type_ctor_field_names(Ordinal),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_field_locns(module_info::in, rtti_type_ctor::in, uint32::in,
list(du_arg_info)::in, bool::out, ml_global_data::in, ml_global_data::out)
is det.
gen_field_locns(_ModuleInfo, RttiTypeCtor, Ordinal, ArgInfos, HaveArgLocns,
!GlobalData) :-
( if
some [ArgInfo] (
list.member(ArgInfo, ArgInfos),
ArgInfo ^ du_arg_pos_width \= apw_full(_, _)
)
then
HaveArgLocns = yes,
RttiName = type_ctor_field_locns(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
list.map(gen_field_locn(RttiId), ArgInfos, ArgLocnInitializers),
Initializer = init_array(ArgLocnInitializers),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData)
else
HaveArgLocns = no
).
:- pred gen_field_locn(rtti_id::in, du_arg_info::in, mlds_initializer::out)
is det.
gen_field_locn(RttiId, ArgInfo, ArgLocnInitializer) :-
ArgPosWidth = ArgInfo ^ du_arg_pos_width,
% The meanings of the various special values of MR_arg_bits
% are documented next to the definition of the MR_DuArgLocn type
% in mercury_type_info.h.
(
ArgPosWidth = apw_full(arg_only_offset(ArgOnlyOffset), _),
Shift = 0,
% NumBits = 0 means the argument takes a full word.
NumBits = 0
;
ArgPosWidth = apw_double(arg_only_offset(ArgOnlyOffset), _,
DoubleWordKind),
Shift = 0,
% NumBits = -1, -2 and -3 mean the argument takes two words,
% containing a float, int64 and uint64 respectively.
(
DoubleWordKind = dw_float,
NumBits = -1
;
DoubleWordKind = dw_int64,
NumBits = -2
;
DoubleWordKind = dw_uint64,
NumBits = -3
)
;
(
ArgPosWidth = apw_partial_first(arg_only_offset(ArgOnlyOffset),
_, arg_shift(Shift), arg_num_bits(NumBits0), _, Fill)
;
ArgPosWidth = apw_partial_shifted(arg_only_offset(ArgOnlyOffset),
_, arg_shift(Shift), arg_num_bits(NumBits0), _, Fill)
),
% NumBits = -4 to -9 mean the argument takes part a word
% and contains an 8, 16 or 32 bit sized int or uint.
(
( Fill = fill_enum
; Fill = fill_char21
),
NumBits = NumBits0
;
Fill = fill_int8,
NumBits = -4
;
Fill = fill_uint8,
NumBits = -5
;
Fill = fill_int16,
NumBits = -6
;
Fill = fill_uint16,
NumBits = -7
;
Fill = fill_int32,
NumBits = -8
;
Fill = fill_uint32,
NumBits = -9
)
;
(
ArgPosWidth = apw_none_shifted(arg_only_offset(ArgOnlyOffset), _)
;
ArgPosWidth = apw_none_nowhere,
ArgOnlyOffset = -1
),
% NumBits = -10 means the argument is of a dummy type,
% and takes no space at all.
Shift = 0,
NumBits = -10
),
ArgLocnInitializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_int(ArgOnlyOffset), % MR_arg_offset
gen_init_int(Shift), % MR_arg_shift
gen_init_int(NumBits) % MR_arg_bits
]).
%-----------------------------------------------------------------------------%
:- pred gen_enum_ordinal_ordered_table(module_info::in, rtti_type_ctor::in,
map(uint32, enum_functor)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor, EnumByOrd,
!GlobalData) :-
map.values(EnumByOrd, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_enum_ordinal_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_enum_name_ordered_table(module_info::in, rtti_type_ctor::in,
map(string, enum_functor)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor, EnumByName,
!GlobalData) :-
map.values(EnumByName, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_enum_name_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_foreign_enum_ordinal_ordered_table(module_info::in,
rtti_type_ctor::in, map(uint32, foreign_enum_functor)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_foreign_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
ForeignEnumByOrdinal, !GlobalData) :-
map.values(ForeignEnumByOrdinal, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_foreign_enum_ordinal_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_foreign_enum_name_ordered_table(module_info::in,
rtti_type_ctor::in, map(string, foreign_enum_functor)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_foreign_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
ForeignEnumByName, !GlobalData) :-
map.values(ForeignEnumByName, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(foreign_enum_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_foreign_enum_name_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_du_ptag_ordered_table(module_info::in, rtti_type_ctor::in,
map(ptag, sectag_table)::in, ml_global_data::in, ml_global_data::out)
is det.
gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, PtagMap, !GlobalData) :-
module_info_get_name(ModuleInfo, ModuleName),
map.to_assoc_list(PtagMap, PtagList),
list.foldl(gen_du_stag_ordered_table(ModuleName, RttiTypeCtor), PtagList,
!GlobalData),
(
PtagList = [FirstPtag - _ | _],
FirstPtag = ptag(LeastPtag)
;
PtagList = [],
unexpected($pred, "bad ptag list")
),
gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, LeastPtag,
PtagList, PtagInitializers),
RttiName = type_ctor_du_ptag_ordered_table,
Initializer = init_array(PtagInitializers),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_du_ptag_ordered_table_body(module_name::in, rtti_type_ctor::in,
uint8::in, assoc_list(ptag, sectag_table)::in, list(mlds_initializer)::out)
is det.
gen_du_ptag_ordered_table_body(_, _, _, [], []).
gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, LeastPtag,
[Ptag - SectagTable | PtagTail], [Initializer | Initializers]) :-
Ptag = ptag(PtagUint8),
% ptags for a subtype may start higher than zero, and may skip values.
expect(LeastPtag =< PtagUint8, $pred, "ptag mismatch"),
SectagTable = sectag_table(SectagLocn, NumSectagBits, NumSharers,
_SectagMap),
RttiName = type_ctor_du_ptag_layout(Ptag),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
compute_du_ptag_layout_flags(SectagTable, Flags),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_sectag_sharers
gen_init_uint32(NumSharers),
% MR_sectag_locn
gen_init_sectag_locn(SectagLocn),
% MR_sectag_alternatives
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_stag_ordered_table(Ptag)),
% MR_sectag_numbits
gen_init_int8(NumSectagBits),
% MR_du_ptag,
gen_init_uint8(PtagUint8),
% MR_du_ptag_flags
gen_init_uint8(encode_du_ptag_layout_flags(Flags))
]),
NextLeastPtag = PtagUint8 + 1u8,
gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, NextLeastPtag,
PtagTail, Initializers).
:- pred gen_du_stag_ordered_table(module_name::in, rtti_type_ctor::in,
pair(ptag, sectag_table)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_du_stag_ordered_table(ModuleName, RttiTypeCtor, Ptag - SectagTable,
!GlobalData) :-
SectagTable = sectag_table(_SectagLocn, _NumSectagBits, _NumSharers,
SectagMap),
map.values(SectagMap, SectagFunctors),
FunctorRttiNames = list.map(du_functor_rtti_name, SectagFunctors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_du_stag_ordered_table(Ptag),
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_du_name_ordered_table(module_info::in, rtti_type_ctor::in,
map(string, map(uint16, du_functor))::in,
ml_global_data::in, ml_global_data::out) is det.
gen_du_name_ordered_table(ModuleInfo, RttiTypeCtor, NameArityMap,
!GlobalData) :-
map.values(NameArityMap, ArityMaps),
list.map(map.values, ArityMaps, FunctorLists),
list.condense(FunctorLists, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(du_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
RttiName = type_ctor_du_name_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- pred gen_functor_number_map(rtti_type_ctor::in, list(uint32)::in,
ml_global_data::in, ml_global_data::out) is det.
gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData) :-
Initializer = gen_init_array(gen_init_functor_number, FunctorNumberMap),
RttiName = type_ctor_functor_number_map,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
:- func gen_init_functor_number(uint32) = mlds_initializer.
gen_init_functor_number(NumUint32) = Init :-
% XXX MAKE_FIELD_UNSIGNED
Num = uint32.cast_to_int(NumUint32),
Init = gen_init_int(Num).
%-----------------------------------------------------------------------------%
:- func gen_init_base_type_ctor(module_name, mlds_target_lang,
maybe(type_ctor)) = mlds_initializer.
gen_init_base_type_ctor(ModuleName, Target, MaybeBaseTypeCtor) = Initializer :-
% The MR_type_ctor_base field is only required in high-level data grades.
( if mlds_target_high_level_data(Target) = yes then
(
MaybeBaseTypeCtor = yes(BaseTypeCtor),
BaseTypeCtor = type_ctor(SymName, Arity),
(
SymName = qualified(TypeModule, TypeName)
;
SymName = unqualified(_),
unexpected($pred, "base type ctor is not module qualified")
),
RttiTypeCtor = rtti_type_ctor(TypeModule, TypeName,
uint16.det_from_int(Arity)),
RttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_ctor_info),
Initializer = gen_init_rtti_id(ModuleName, RttiId)
;
MaybeBaseTypeCtor = no,
% The type is a lie, but a safe one.
Initializer = gen_init_null_pointer(mlds_generic_type)
)
else
Initializer = no_initializer
).
%-----------------------------------------------------------------------------%
:- func gen_init_rtti_names_array(module_name, rtti_type_ctor,
list(ctor_rtti_name)) = mlds_initializer.
gen_init_rtti_names_array(ModuleName, RttiTypeCtor, RttiNames) =
gen_init_array(gen_init_rtti_name(ModuleName, RttiTypeCtor), RttiNames).
:- func gen_init_cast_rtti_datas_array(mlds_type, module_name,
list(rtti_data)) = mlds_initializer.
gen_init_cast_rtti_datas_array(Type, ModuleName, RttiDatas) =
gen_init_array(gen_init_cast_rtti_data(Type, ModuleName), RttiDatas).
% Generate the MLDS initializer comprising the rtti_name
% for a given rtti_data, converted to mlds_generic_type.
%
:- func gen_init_cast_rtti_data(mlds_type, module_name, rtti_data) =
mlds_initializer.
gen_init_cast_rtti_data(DestType, ModuleName, RttiData) = Initializer :-
( if
RttiData = rtti_data_pseudo_type_info(type_var(VarNum))
then
% rtti_data_to_id/3 does not handle this case
SrcType = mlds_builtin_type_int(int_type_int),
Initializer = init_obj(gen_cast(SrcType, DestType,
ml_const(mlconst_int(VarNum))))
else if
RttiData = rtti_data_base_typeclass_info(TCName, InstanceModuleName,
InstanceString, _)
then
SrcType = mlds_rtti_type(item_type(tc_rtti_id(TCName,
type_class_base_typeclass_info(InstanceModuleName,
InstanceString)))),
MLDS_ModuleName = mercury_module_name_to_mlds(InstanceModuleName),
RttiId = tc_rtti_id(TCName, type_class_base_typeclass_info(
InstanceModuleName, InstanceString)),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)),
Initializer = init_obj(gen_cast(SrcType, DestType, Rval))
else
rtti_data_to_id(RttiData, RttiId),
Initializer = gen_init_cast_rtti_id(DestType, ModuleName, RttiId)
).
% Currently casts only store the destination type.
%
:- func gen_cast(mlds_type, mlds_type, mlds_rval) = mlds_rval.
gen_cast(_SrcType, DestType, SubRval) = ml_cast(DestType, SubRval).
% Generate an MLDS initializer comprising just the rval
% for a given rtti_id.
%
:- func gen_init_rtti_id(module_name, rtti_id) = mlds_initializer.
gen_init_rtti_id(ModuleName, ctor_rtti_id(RttiTypeCtor, RttiName)) =
gen_init_rtti_name(ModuleName, RttiTypeCtor, RttiName).
gen_init_rtti_id(ModuleName, tc_rtti_id(TCName, TCRttiName)) =
gen_init_tc_rtti_name(ModuleName, TCName, TCRttiName).
% Generate an MLDS initializer comprising just the rval
% for a given rtti_name.
%
:- func gen_init_rtti_name(module_name, rtti_type_ctor, ctor_rtti_name) =
mlds_initializer.
gen_init_rtti_name(ModuleName, RttiTypeCtor, RttiName) =
init_obj(gen_rtti_name(ModuleName, RttiTypeCtor, RttiName)).
% Generate an MLDS initializer comprising just the rval
% for a given tc_rtti_name.
%
:- func gen_init_tc_rtti_name(module_name, tc_name, tc_rtti_name) =
mlds_initializer.
gen_init_tc_rtti_name(ModuleName, TCName, TCRttiName) =
init_obj(gen_tc_rtti_name(ModuleName, TCName, TCRttiName)).
% Generate the MLDS initializer comprising the rtti_name
% for a given rtti_name, converted to the given type.
%
:- func gen_init_cast_rtti_id(mlds_type, module_name, rtti_id)
= mlds_initializer.
gen_init_cast_rtti_id(DestType, ModuleName, RttiId) = Initializer :-
SrcType = mlds_rtti_type(item_type(RttiId)),
Initializer = init_obj(gen_cast(SrcType, DestType,
gen_rtti_id(ModuleName, RttiId))).
% Generate the MLDS rval for an rtti_id.
%
:- func gen_rtti_id(module_name, rtti_id) = mlds_rval.
gen_rtti_id(ThisModuleName, ctor_rtti_id(RttiTypeCtor, RttiName)) =
gen_rtti_name(ThisModuleName, RttiTypeCtor, RttiName).
gen_rtti_id(ThisModuleName, tc_rtti_id(TCName, TCRttiName)) =
gen_tc_rtti_name(ThisModuleName, TCName, TCRttiName).
:- func gen_rtti_name(module_name, rtti_type_ctor, ctor_rtti_name)
= mlds_rval.
gen_rtti_name(ThisModuleName, RttiTypeCtor0, RttiName) = Rval :-
% Typeinfos and pseudo typeinfos are defined locally to each module.
% Other kinds of RTTI data are defined in the module that defines
% the type which they are for.
( if
(
RttiName = type_ctor_type_info(TypeInfo),
( TypeInfo = plain_type_info(_, _)
; TypeInfo = var_arity_type_info(_, _)
)
;
RttiName = type_ctor_pseudo_type_info(PseudoTypeInfo),
( PseudoTypeInfo = plain_pseudo_type_info(_, _)
; PseudoTypeInfo = var_arity_pseudo_type_info(_, _)
)
)
then
ModuleName = ThisModuleName,
RttiTypeCtor = RttiTypeCtor0
else
RttiTypeCtor0 = rtti_type_ctor(RttiModuleName,
RttiTypeName, RttiTypeArity),
% Although the builtin types `int', `float', etc. are treated
% as part of the `builtin' module, for historical reasons they
% don't have any qualifiers at this point, so we need to add
% the `builtin' qualifier now.
( if RttiModuleName = unqualified("") then
ModuleName = mercury_public_builtin_module,
RttiTypeCtor = rtti_type_ctor(RttiModuleName,
RttiTypeName, RttiTypeArity)
else
ModuleName = RttiModuleName,
RttiTypeCtor = RttiTypeCtor0
)
),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)).
:- func gen_tc_rtti_name(module_name, tc_name, tc_rtti_name) = mlds_rval.
gen_tc_rtti_name(_ThisModuleName, TCName, TCRttiName) = Rval :-
(
TCRttiName = type_class_base_typeclass_info(InstanceModuleName, _),
MLDS_ModuleName = mercury_module_name_to_mlds(InstanceModuleName)
;
TCRttiName = type_class_id,
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_decl,
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_decl_super(_, _),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_decl_supers,
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_id_var_names,
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_id_method_ids,
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_instance(_Types),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_instance_tc_type_vector(_Types),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_instance_constraint(_Types, _, _),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_instance_constraints(_Types),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
;
TCRttiName = type_class_instance_methods(_Types),
MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
),
RttiId = tc_rtti_id(TCName, TCRttiName),
Rval = ml_const(mlconst_data_addr_rtti(MLDS_ModuleName, RttiId)).
:- func mlds_module_name_from_tc_name(tc_name) = mlds_module_name.
mlds_module_name_from_tc_name(TCName) = MLDS_ModuleName :-
TCName = tc_name(ModuleName, _ClassName, _Arity),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName).
%-----------------------------------------------------------------------------%
:- pred gen_pseudo_type_info(module_info::in, mlds_target_lang::in,
rtti_data::in, mlds_initializer::out,
ml_global_data::in, ml_global_data::out) is det.
gen_pseudo_type_info(ModuleInfo, Target, PTIRttiData, Initializer,
!GlobalData) :-
( if real_rtti_data(PTIRttiData) then
add_rtti_data_to_mlds(ModuleInfo, Target, PTIRttiData, !GlobalData)
else
% Since PTIRttiData does not correspond to a global data definition,
% we have nothing to do.
true
),
module_info_get_name(ModuleInfo, ModuleName),
Initializer = gen_init_cast_rtti_data(mlds_pseudo_type_info_type,
ModuleName, PTIRttiData).
:- pred gen_pseudo_type_info_array(module_info::in, mlds_target_lang::in,
list(rtti_data)::in, mlds_initializer::out,
ml_global_data::in, ml_global_data::out) is det.
gen_pseudo_type_info_array(ModuleInfo, Target, PTIRttiDatas, Initializer,
!GlobalData) :-
RealRttiDatas = list.filter(real_rtti_data, PTIRttiDatas),
list.foldl(add_rtti_data_to_mlds(ModuleInfo, Target),
RealRttiDatas, !GlobalData),
module_info_get_name(ModuleInfo, ModuleName),
Initializer = gen_init_cast_rtti_datas_array(mlds_pseudo_type_info_type,
ModuleName, PTIRttiDatas).
%-----------------------------------------------------------------------------%
:- pred gen_init_method(module_info::in, mlds_target_lang::in,
int::in, rtti_proc_label::in, mlds_initializer::out,
ml_global_data::in, ml_global_data::out) is det.
gen_init_method(ModuleInfo, Target, NumExtra, RttiProcLabel, Initializer,
!GlobalData) :-
% We can't store the address of the typeclass method directly in the
% base_typeclass_info; instead, we need to generate a wrapper function
% that extracts the NumExtra parameters it needs from the typeclass_info,
% and store the address of that wrapper function in the
% base_typeclass_info.
%
% Note that this means there are two levels of wrappers: the wrapper that
% we generate here calls the procedure introduced by check_typeclass.m,
% and that in turn calls the user's procedure. Hopefully the Mercury
% HLDS->HLDS inlining and/or the target code compiler will be able
% to optimize this...
%
gen_wrapper_func_and_initializer(ModuleInfo, Target, NumExtra,
RttiProcLabel, typeclass_info_closure, Initializer, !GlobalData).
:- pred gen_init_special_pred(module_info::in, mlds_target_lang::in,
univ::in, mlds_initializer::out,
ml_global_data::in, ml_global_data::out) is det.
gen_init_special_pred(ModuleInfo, Target, RttiProcIdUniv, Initializer,
!GlobalData) :-
% We can't store the address of the special pred procedure directly in the
% type_ctor_info because when the special pred is called by looking up
% its address in the type_ctor_info it is always called with its arguments
% boxed, but the generated special pred may operate on unboxed values,
% hence we need to generate a wrapper function which unboxes the arguments
% if necessary.
det_univ_to_type(RttiProcIdUniv, RttiProcId),
( if RttiProcId ^ rpl_proc_arity = pred_form_arity(0) then
% If there are no arguments, then there is no unboxing to do,
% so we don't need a wrapper. (This case can occur with
% --no-special-preds, where the procedure will be
% private_builtin.unused/0.)
% XXX --no-special-preds does not exist anymore.
Initializer = gen_init_proc_id(ModuleInfo, RttiProcId)
else
NumExtra = 0,
gen_wrapper_func_and_initializer(ModuleInfo, Target,
NumExtra, RttiProcId, special_pred_closure, Initializer,
!GlobalData)
).
:- pred gen_wrapper_func_and_initializer(module_info::in, mlds_target_lang::in,
int::in, rtti_proc_label::in, closure_kind::in, mlds_initializer::out,
ml_global_data::in, ml_global_data::out) is det.
gen_wrapper_func_and_initializer(ModuleInfo, Target, NumExtra, RttiProcId,
ClosureKind, Initializer, !GlobalData) :-
some [!Info] (
% We start off by creating a fresh MLGenInfo here, using the pred_id
% and proc_id of the wrapped procedure. This requires considerable
% care. We need to call ml_gen_info_bump_counters to ensure that
% the function label allocated for the wrapper func does not overlap
% with any function labels used when generating code for the wrapped
% procedure.
%
% The empty const struct map is a lie, but a white lie; the RTTI
% data cannot contain any type_info_const or typeclass_info_const
% cons_ids.
PredId = RttiProcId ^ rpl_pred_id,
ProcId = RttiProcId ^ rpl_proc_id,
PredProcId = proc(PredId, ProcId),
InSccInfo = in_scc_info(not_in_tscc,
is_not_target_of_self_trcall, is_not_target_of_mutual_trcall, []),
InSccMap = map.singleton(PredProcId, InSccInfo),
init_ml_gen_tscc_info(ModuleInfo, InSccMap, tscc_self_rec_only,
TsccInfo),
module_info_proc_info(ModuleInfo, PredId, ProcId, ProcInfo),
!:Info = ml_gen_info_init(ModuleInfo, Target, map.init, PredProcId,
ProcInfo, !.GlobalData, TsccInfo),
ml_gen_info_bump_counters(!Info),
% Now we can safely go ahead and generate the wrapper function.
Context = dummy_context,
ml_gen_closure_wrapper(PredId, ProcId, ClosureKind, NumExtra, Context,
WrapperFuncRval, WrapperFuncType, !Info),
ml_gen_info_get_closure_wrapper_defns(!.Info, ClosureWrapperDefns),
ml_gen_info_get_global_data(!.Info, !:GlobalData),
ml_global_data_add_closure_wrapper_func_defns(ClosureWrapperDefns,
!GlobalData),
% The initializer for the wrapper is just the wrapper function's
% address, converted to mlds_generic_type (by boxing).
Initializer = init_obj(ml_box(WrapperFuncType, WrapperFuncRval))
).
:- func gen_init_proc_id(module_info, rtti_proc_label) = mlds_initializer.
gen_init_proc_id(ModuleInfo, RttiProcId) = Initializer :-
% Construct an rval for the address of this procedure
% (this is similar to ml_gen_proc_addr_rval).
ml_gen_pred_label_from_rtti(ModuleInfo, RttiProcId, PredLabel, PredModule),
ProcId = RttiProcId ^ rpl_proc_id,
ProcLabel = mlds_proc_label(PredLabel, ProcId),
FuncLabel = mlds_func_label(ProcLabel, proc_func),
QualFuncLabel = qual_func_label(PredModule, FuncLabel),
Params = ml_gen_proc_params_from_rtti_no_gc_stmts(ModuleInfo, RttiProcId),
Signature = mlds_get_func_signature(Params),
CodeAddr = mlds_code_addr(QualFuncLabel, Signature),
ProcAddrRval = ml_const(mlconst_code_addr(CodeAddr)),
% Convert the procedure address to a generic type. We need to use a
% generic type because since the actual type for the procedure will
% depend on how many type_info parameters it takes, which will depend
% on the type's arity.
ProcAddrArg = ml_box(mlds_func_type(Params), ProcAddrRval),
Initializer = init_obj(ProcAddrArg).
:- func gen_init_proc_id_from_univ(module_info, univ) =
mlds_initializer.
:- pragma consider_used(func(gen_init_proc_id_from_univ/2)).
gen_init_proc_id_from_univ(ModuleInfo, ProcLabelUniv) = Initializer :-
det_univ_to_type(ProcLabelUniv, ProcLabel),
Initializer = gen_init_proc_id(ModuleInfo, ProcLabel).
% Succeed iff the specified rtti_data is one that requires an
% explicit mlds_defn to define it.
%
:- pred real_rtti_data(rtti_data::in) is semidet.
real_rtti_data(RttiData) :-
not (
(
RttiData = rtti_data_type_info(TypeInfo),
TypeInfo = plain_arity_zero_type_info(_)
;
RttiData = rtti_data_pseudo_type_info(PseudoTypeInfo),
( PseudoTypeInfo = plain_arity_zero_pseudo_type_info(_)
; PseudoTypeInfo = type_var(_)
)
)
).
%-----------------------------------------------------------------------------%
%
% Conversion functions for builtin enumeration types.
%
% This handles sectag_locn, functor_subtype_info and type_ctor_rep. The rvals
% generated are just named constants in the private_builtin module, which the
% Mercury runtime is expected to define.
%
:- func gen_init_pred_or_func(pred_or_func) = mlds_initializer.
gen_init_pred_or_func(PredOrFunc) = Initializer :-
rtti.pred_or_func_to_target_string(PredOrFunc, TargetPrefixes, Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
:- func gen_init_sectag_locn(sectag_locn) = mlds_initializer.
gen_init_sectag_locn(Locn) = Initializer :-
rtti.sectag_locn_to_string(Locn, TargetPrefixes, Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
:- func gen_init_functor_subtype_info(functor_subtype_info) = mlds_initializer.
gen_init_functor_subtype_info(Info) = Initializer :-
rtti.functor_subtype_info_to_string(Info, TargetPrefixes,
Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
:- func gen_init_type_ctor_rep(type_ctor_data) = mlds_initializer.
gen_init_type_ctor_rep(TypeCtorData) = Initializer :-
rtti.type_ctor_rep_to_string(TypeCtorData, TargetPrefixes, Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
%-----------------------------------------------------------------------------%
%
% Ordering RTTI definitions.
%
order_mlds_rtti_defns(Defns) = OrdDefns :-
some [!Graph] (
digraph.init(!:Graph),
list.foldl2(add_rtti_defn_nodes, Defns, !Graph, map.init, NameMap),
list.foldl(add_rtti_defn_arcs, Defns, !Graph),
OrdSets = digraph.return_sccs_in_to_from_order(!.Graph)
),
list.map(set.to_sorted_list, OrdSets, OrdLists),
list.map(list.filter_map(map.search(NameMap)), OrdLists, OrdDefns).
:- pred add_rtti_defn_nodes(mlds_global_var_defn::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out,
map(mlds_global_var_name, mlds_global_var_defn)::in,
map(mlds_global_var_name, mlds_global_var_defn)::out) is det.
add_rtti_defn_nodes(GlobalVarDefn, !Graph, !NameMap) :-
GlobalVarName = GlobalVarDefn ^ mgvd_name,
digraph.add_vertex(GlobalVarName, _, !Graph),
map.det_insert(GlobalVarName, GlobalVarDefn, !NameMap).
:- pred add_rtti_defn_arcs(mlds_global_var_defn::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out)
is det.
add_rtti_defn_arcs(GlobalVarDefn, !Graph) :-
GlobalVarDefn =
mlds_global_var_defn(GlobalVarName, _, _, Type, Initializer, _GCStmt),
( if Type = mlds_rtti_type(_) then
add_rtti_defn_arcs_initializer(GlobalVarName, Initializer, !Graph)
else
unexpected($pred, "expected rtti entity_data")
).
:- pred add_rtti_defn_arcs_initializer(mlds_global_var_name::in,
mlds_initializer::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out)
is det.
add_rtti_defn_arcs_initializer(DefnGlobalVarName, Initializer, !Graph) :-
(
Initializer = init_obj(Rval),
add_rtti_defn_arcs_rval(DefnGlobalVarName, Rval, !Graph)
;
( Initializer = init_struct(_, Initializers)
; Initializer = init_array(Initializers)
),
list.foldl(add_rtti_defn_arcs_initializer(DefnGlobalVarName),
Initializers, !Graph)
;
Initializer = no_initializer
).
:- pred add_rtti_defn_arcs_rval(mlds_global_var_name::in, mlds_rval::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out)
is det.
add_rtti_defn_arcs_rval(DefnGlobalVarName, Rval, !Graph) :-
(
Rval = ml_lval(Lval),
add_rtti_defn_arcs_lval(DefnGlobalVarName, Lval, !Graph)
;
Rval = ml_const(Const),
add_rtti_defn_arcs_const(DefnGlobalVarName, Const, !Graph)
;
( Rval = ml_mkword(_Tag, SubRvalA)
; Rval = ml_box(_, SubRvalA)
; Rval = ml_unbox(_, SubRvalA)
; Rval = ml_cast(_, SubRvalA)
; Rval = ml_unop(_, SubRvalA)
; Rval = ml_vector_common_row_addr(_, SubRvalA)
),
add_rtti_defn_arcs_rval(DefnGlobalVarName, SubRvalA, !Graph)
;
Rval = ml_binop(_, SubRvalA, SubRvalB),
add_rtti_defn_arcs_rval(DefnGlobalVarName, SubRvalA, !Graph),
add_rtti_defn_arcs_rval(DefnGlobalVarName, SubRvalB, !Graph)
;
Rval = ml_mem_addr(SubLval),
add_rtti_defn_arcs_lval(DefnGlobalVarName, SubLval, !Graph)
;
( Rval = ml_scalar_common(_)
; Rval = ml_scalar_common_addr(_)
; Rval = ml_self(_)
)
).
:- pred add_rtti_defn_arcs_lval(mlds_global_var_name::in, mlds_lval::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out)
is det.
add_rtti_defn_arcs_lval(DefnGlobalVarName, Lval, !Graph) :-
(
( Lval = ml_field(_, SubRval, _, _, _)
; Lval = ml_mem_ref(SubRval, _)
),
add_rtti_defn_arcs_rval(DefnGlobalVarName, SubRval, !Graph)
;
( Lval = ml_target_global_var_ref(env_var_ref(_))
; Lval = ml_local_var(_, _)
; Lval = ml_global_var(_, _)
)
).
:- pred add_rtti_defn_arcs_const(mlds_global_var_name::in,
mlds_rval_const::in,
digraph(mlds_global_var_name)::in, digraph(mlds_global_var_name)::out)
is det.
add_rtti_defn_arcs_const(DefnGlobalVarName, Const, !Graph) :-
(
Const = mlconst_data_addr_rtti(_, RttiId),
GlobalVarName = gvn_rtti_var(RttiId),
digraph.add_vertices_and_edge(DefnGlobalVarName, GlobalVarName, !Graph)
;
( Const = mlconst_true
; Const = mlconst_false
; Const = mlconst_int(_)
; Const = mlconst_uint(_)
; Const = mlconst_int8(_)
; Const = mlconst_uint8(_)
; Const = mlconst_int16(_)
; Const = mlconst_uint16(_)
; Const = mlconst_int32(_)
; Const = mlconst_uint32(_)
; Const = mlconst_int64(_)
; Const = mlconst_uint64(_)
; Const = mlconst_enum(_, _)
; Const = mlconst_char(_)
; Const = mlconst_foreign(_, _, _)
; Const = mlconst_float(_)
; Const = mlconst_string(_)
; Const = mlconst_multi_string(_)
; Const = mlconst_named_const(_, _)
; Const = mlconst_code_addr(_)
; Const = mlconst_data_addr_local_var(_)
; Const = mlconst_data_addr_global_var(_, _)
; Const = mlconst_data_addr_tabling(_, _)
; Const = mlconst_null(_)
)
).
%-----------------------------------------------------------------------------%
:- end_module ml_backend.rtti_to_mlds.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink