[m-rev.] for review: new erlang RTTI
Peter Ross
pro at missioncriticalit.com
Fri Jun 1 10:28:05 AEST 2007
Hi,
===================================================================
Estimated hours taken: 12
Branches: main
New implementation of RTTI for the Erlang backend. Currently the RTTI only
supports generic compare and unify, deconstruct and construct are still to
come.
compiler/erl_rtti.m:
Add a function which converts rtti_data to erlang_rtti_data.
Change rtti_data_list_to_elds to operate on erlang_rtti_data,
and output a erlang tuple which represents a type_ctor_info.
compiler/erlang_rtti.m:
The definition of the RTTI needed for the Erlang backend,
for the moment only the type_ctor_info differs from the
low-level backends.
This was designed in conjunction with zs.
compiler/backend_libs.m:
Add erlang_rtti.
compiler/elds.m:
Add a utility predicate which returns the erlang representation
of enum type for a given functor.
compiler/mercury_compile.m:
Call the new erl_rtti predicates.
library/builtin.m:
Call the erlang_rtti_implementation generic compare and unify
predicates.
library/erlang_rtti_implementation.m:
An implementation of generic compare and unify in Mercury,
with some tiny bits of erlang foreign_procs to inspect a type_info
and type_ctor_info.
library/library.m:
Reference the erlang_rtti_implementation module.
library/rtti_implementation.m:
Remove all the Erlang code as this implementation of
RTTI is too low-level.
Index: compiler/backend_libs.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/backend_libs.m,v
retrieving revision 1.11
diff -u -r1.11 backend_libs.m
--- compiler/backend_libs.m 27 Sep 2006 06:16:46 -0000 1.11
+++ compiler/backend_libs.m 31 May 2007 13:10:51 -0000
@@ -20,6 +20,7 @@
:- include_module bytecode_data.
:- include_module c_util.
:- include_module compile_target_code.
+:- include_module erlang_rtti.
:- include_module export.
:- include_module foreign.
:- include_module interval.
Index: compiler/elds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/elds.m,v
retrieving revision 1.6
diff -u -r1.6 elds.m
--- compiler/elds.m 30 May 2007 08:16:01 -0000 1.6
+++ compiler/elds.m 31 May 2007 13:10:51 -0000
@@ -324,6 +324,16 @@
:- func elds_clause_arity(elds_clause) = arity.
+ %
+ % make_enum_alternative(F)
+ %
+ % returns the erlang representation of the functor, F, provided
+ % F is part of an enum type.
+ % An enum type is a du type where none of the functors have arguments.
+ % eg :- type t ---> f ; g ; h.
+ %
+:- func make_enum_alternative(string) = elds_term.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -400,6 +410,8 @@
elds_body_arity(body_external(Arity)) = Arity.
elds_clause_arity(elds_clause(Args, _Expr)) = list.length(Args).
+
+make_enum_alternative(F) = elds_tuple([elds_term(elds_atom_raw(F))]).
%-----------------------------------------------------------------------------%
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.2
diff -u -r1.2 erl_rtti.m
--- compiler/erl_rtti.m 30 May 2007 08:16:01 -0000 1.2
+++ compiler/erl_rtti.m 31 May 2007 13:10:51 -0000
@@ -7,7 +7,7 @@
%-----------------------------------------------------------------------------%
%
% File: erl_rtti.m.
-% Main author: wangp.
+% Main author: wangp, petdr
%
% This module converts from the back-end-independent RTTI data structures into
% ELDS function definitions.
@@ -20,6 +20,8 @@
:- interface.
:- import_module backend_libs.rtti.
+:- import_module backend_libs.erlang_rtti.
+
:- import_module erl_backend.elds.
:- import_module hlds.hlds_module.
@@ -27,8 +29,18 @@
%-----------------------------------------------------------------------------%
-:- pred rtti_data_list_to_elds(module_info::in, list(rtti_data)::in,
- list(elds_rtti_defn)::out) is det.
+ %
+ % erlang_rtti_data(MI, RD)
+ %
+ % converts from rtti_data to erlang_rtti_data.
+ %
+:- func erlang_rtti_data(module_info, rtti_data) = erlang_rtti_data.
+
+ %
+ % Generate a representation of all the erlang RTTI
+ %
+:- pred rtti_data_list_to_elds(module_info::in,
+ list(erlang_rtti_data)::in, list(elds_rtti_defn)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -47,21 +59,187 @@
:- import_module bool.
:- import_module int.
:- import_module maybe.
+:- import_module string.
:- import_module svvarset.
:- import_module univ.
:- import_module varset.
%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- import_module require.
+
+erlang_rtti_data(_, rtti_data_type_ctor_info(TypeCtorData)) = RttiData :-
+ TypeCtorData = type_ctor_data(Version, ModuleName, TypeName,
+ Arity, UnifyPred, ComparePred, _Flags, Details),
+ ErlangUnify = maybe_get_special_predicate(UnifyPred),
+ ErlangCompare = maybe_get_special_predicate(ComparePred),
+ ErlangDetails = erlang_type_ctor_details(ModuleName,
+ TypeName, Arity, Details),
+ ErlangTypeCtorData = erlang_type_ctor_data(Version, ModuleName, TypeName,
+ Arity, ErlangUnify, ErlangCompare, ErlangDetails),
+ RttiData = erlang_rtti_data_type_ctor_info(ErlangTypeCtorData).
+erlang_rtti_data(_, rtti_data_type_info(TypeInfo)) =
+ erlang_rtti_data_type_info(TypeInfo).
+erlang_rtti_data(_, rtti_data_pseudo_type_info(PseudoTypeInfo)) =
+ erlang_rtti_data_pseudo_type_info(PseudoTypeInfo).
+erlang_rtti_data(_, rtti_data_base_typeclass_info(Name, Module, Enc, TCI)) =
+ erlang_rtti_data_base_typeclass_info(Name, Module, Enc, TCI).
+erlang_rtti_data(_, rtti_data_type_class_decl(TCDecl)) =
+ erlang_rtti_data_type_class_decl(TCDecl).
+erlang_rtti_data(_, rtti_data_type_class_instance(TCInstance)) =
+ erlang_rtti_data_type_class_instance(TCInstance).
+
+:- func maybe_get_special_predicate(univ) = maybe(rtti_proc_label).
+
+maybe_get_special_predicate(Univ) =
+ ( univ_to_type(Univ, ProcLabel) ->
+ yes(ProcLabel)
+ ;
+ no
+ ).
+
+ %
+ % Given the type_ctor_details return the erlang version of those
+ % details.
+ % This means conflating enum and no_tags into erlang_du,
+ % aborting on reserved types, and specially handling the list type.
+ %
+:- func erlang_type_ctor_details(module_name, string,
+ int, type_ctor_details) = erlang_type_ctor_details.
+
+erlang_type_ctor_details(ModuleName, TypeName, Arity, Details) = D :-
+ (
+ ModuleName = unqualified("list"),
+ TypeName = "list",
+ Arity = 1
+ ->
+ ( list_argument_type(Details, Type) ->
+ D = erlang_list(Type)
+ ;
+ unexpected(this_file, "erlang_type_ctor_details: " ++
+ "unable to determine type of list argument")
+ )
+ ;
+ D = erlang_type_ctor_details_2(Details)
+ ).
+
+ %
+ % Given a type_ctor_detail which represents a list,
+ % determine type type of the argument to the list.
+ %
+:- pred list_argument_type(type_ctor_details::in,
+ rtti_maybe_pseudo_type_info::out) is semidet.
+
+list_argument_type(Details, Type) :-
+ Functors = Details ^ du_functors,
+ list_argument_type_2(Functors, Type).
+
+:- pred list_argument_type_2(list(du_functor)::in,
+ rtti_maybe_pseudo_type_info::out) is semidet.
+
+list_argument_type_2([Functor | Functors], Type) :-
+ ( Functor ^ du_name = "[|]" ->
+ Functor ^ du_arg_infos = [du_arg_info(_, Type0), _],
+ convert_to_rtti_maybe_pseudo_type_info(Type0, Type)
+ ;
+ list_argument_type_2(Functors, Type)
+ ).
+
+:- pred convert_to_rtti_maybe_pseudo_type_info(
+ rtti_maybe_pseudo_type_info_or_self::in,
+ rtti_maybe_pseudo_type_info::out) is semidet.
+
+convert_to_rtti_maybe_pseudo_type_info(plain(P), plain(P)).
+convert_to_rtti_maybe_pseudo_type_info(pseudo(P), pseudo(P)).
+
+:- func erlang_type_ctor_details_2(type_ctor_details) =
+ erlang_type_ctor_details.
+
+erlang_type_ctor_details_2(enum(_, Functors, _, _, _IsDummy, _)) =
+ % XXX Handle IsDummy
+ erlang_du(list.map(convert_enum_functor, Functors)).
+erlang_type_ctor_details_2(du(_, Functors, _, _, _)) =
+ erlang_du(list.map(convert_du_functor, Functors)).
+erlang_type_ctor_details_2(reserved(_, _, _, _, _, _)) =
+ % Reserved types are not supported on the Erlang backend.
+ unexpected(this_file, "erlang_type_ctor_details: reserved").
+erlang_type_ctor_details_2(notag(_, NoTagFunctor)) = Details :-
+ NoTagFunctor = notag_functor(Name, TypeInfo, ArgName),
+ ArgTypeInfo = convert_to_rtti_maybe_pseudo_type_info_or_self(TypeInfo),
+ ArgInfos = [du_arg_info(ArgName, ArgTypeInfo)],
+ DUFunctor = erlang_du_functor(Name, 0, 1, Name, ArgInfos, no),
+ Details = erlang_du([DUFunctor]).
+erlang_type_ctor_details_2(eqv(Type)) = erlang_eqv(Type).
+erlang_type_ctor_details_2(builtin(Builtin)) = erlang_builtin(Builtin).
+erlang_type_ctor_details_2(impl_artifact(Impl)) = erlang_impl_artifact(EImpl) :-
+ EImpl = erlang_impl_ctor(Impl).
+erlang_type_ctor_details_2(foreign(_)) = erlang_foreign.
+
+ %
+ % Convert an enum_functor into the equivalent erlang_du_functor
+ %
+:- func convert_enum_functor(enum_functor) = erlang_du_functor.
+
+convert_enum_functor(enum_functor(Name, _)) =
+ erlang_du_functor(Name, 0, 1, Name, [], no).
+
+ %
+ % Convert a du_functor into the equivalent erlang_du_functor
+ %
+:- func convert_du_functor(du_functor) = erlang_du_functor.
+
+convert_du_functor(du_functor(Name, Arity, Ordinal, _, ArgInfos, Exist)) =
+ erlang_du_functor(Name, Arity, Ordinal + 1, Name, ArgInfos, Exist).
+
+:- func convert_to_rtti_maybe_pseudo_type_info_or_self(
+ rtti_maybe_pseudo_type_info) = rtti_maybe_pseudo_type_info_or_self.
+
+convert_to_rtti_maybe_pseudo_type_info_or_self(pseudo(P)) = pseudo(P).
+convert_to_rtti_maybe_pseudo_type_info_or_self(plain(P)) = plain(P).
+
+ %
+ % Restrict the implementation artificats to only those
+ % allowed on the erlang backend.
+ %
+:- func erlang_impl_ctor(impl_ctor) = erlang_impl_ctor.
+
+erlang_impl_ctor(impl_ctor_hp) = erlang_impl_ctor_hp.
+erlang_impl_ctor(impl_ctor_subgoal) = erlang_impl_ctor_subgoal.
+erlang_impl_ctor(impl_ctor_ticket) = erlang_impl_ctor_ticket.
+erlang_impl_ctor(impl_ctor_type_info) = erlang_impl_ctor_type_info.
+erlang_impl_ctor(impl_ctor_type_ctor_info) = erlang_impl_ctor_type_ctor_info.
+erlang_impl_ctor(impl_ctor_typeclass_info) = erlang_impl_ctor_typeclass_info.
+erlang_impl_ctor(impl_ctor_base_typeclass_info) =
+ erlang_impl_ctor_base_typeclass_info.
+
+ % The following implementation artificats are never used
+ % on the erlang backend.
+erlang_impl_ctor(impl_ctor_succip) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_succip").
+erlang_impl_ctor(impl_ctor_maxfr) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_maxfr").
+erlang_impl_ctor(impl_ctor_curfr) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_curfr").
+erlang_impl_ctor(impl_ctor_redofr) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_redofr").
+erlang_impl_ctor(impl_ctor_redoip) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_redoip").
+erlang_impl_ctor(impl_ctor_trail_ptr) = _ :-
+ unexpected(this_file, "erlang_impl_ctor: impl_ctor_trail_ptr").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
rtti_data_list_to_elds(ModuleInfo, RttiDatas, RttiDefns) :-
list.map(rtti_data_to_elds(ModuleInfo), RttiDatas, RttiDefns0),
RttiDefns = list.condense(RttiDefns0).
-:- pred rtti_data_to_elds(module_info::in, rtti_data::in,
+:- pred rtti_data_to_elds(module_info::in, erlang_rtti_data::in,
list(elds_rtti_defn)::out) is det.
rtti_data_to_elds(ModuleInfo, RttiData, [RttiDefn]) :-
- RttiData = rtti_data_base_typeclass_info(TCName, InstanceModule,
+ RttiData = erlang_rtti_data_base_typeclass_info(TCName, InstanceModule,
InstanceStr, BaseTypeClassInfo),
BaseTypeClassInfo = base_typeclass_info(N1, N2, N3, N4, N5, Methods),
NumExtra = BaseTypeClassInfo ^ num_extra,
@@ -85,18 +263,17 @@
elds_clause([], elds_term(BaseTypeClassInfoData))).
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_info(_TypeInfo),
+ RttiData = erlang_rtti_data_type_info(_TypeInfo),
unexpected(this_file, "rtti_data_to_elds: rtti_data_type_info").
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_pseudo_type_info(_PseudoTypeInfo),
+ RttiData = erlang_rtti_data_pseudo_type_info(_PseudoTypeInfo),
unexpected(this_file, "rtti_data_to_elds: rtti_data_pseudo_type_info").
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_class_decl(_TCDecl).
+ RttiData = erlang_rtti_data_type_class_decl(_TCDecl).
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_class_instance(_Instance),
- unexpected(this_file, "rtti_data_to_elds: rtti_data_type_class_instance").
+ RttiData = erlang_rtti_data_type_class_instance(_Instance).
rtti_data_to_elds(ModuleInfo, RttiData, RttiDefns) :-
- RttiData = rtti_data_type_ctor_info(TypeCtorData),
+ RttiData = erlang_rtti_data_type_ctor_info(TypeCtorData),
type_ctor_data_to_elds(ModuleInfo, TypeCtorData, RttiDefns).
%-----------------------------------------------------------------------------%
@@ -232,37 +409,29 @@
% See MR_TypeCtorInfo_Struct in runtime/mercury_type_info.h
%
-:- pred type_ctor_data_to_elds(module_info::in, type_ctor_data::in,
+:- pred type_ctor_data_to_elds(module_info::in, erlang_type_ctor_data::in,
list(elds_rtti_defn)::out) is det.
type_ctor_data_to_elds(ModuleInfo, TypeCtorData, RttiDefns) :-
- TypeCtorData = type_ctor_data(Version, ModuleName, TypeName, Arity,
- UnifyUniv, CompareUniv, Flags, Details),
- NumPtags = type_ctor_details_num_ptags(Details),
- type_ctor_rep_to_string(TypeCtorData, TypeCtorRep),
- NumFunctors = type_ctor_details_num_functors(Details),
+ TypeCtorData = erlang_type_ctor_data(Version, ModuleName, TypeName, Arity,
+ UnifyProcLabel, CompareProcLabel, Details),
some [!VarSet] (
varset.init(!:VarSet),
- gen_init_special_pred(ModuleInfo, UnifyUniv, UnifyExpr, !VarSet),
- gen_init_special_pred(ModuleInfo, CompareUniv, CompareExpr, !VarSet),
+ gen_init_special_pred(ModuleInfo, UnifyProcLabel, UnifyExpr, !VarSet),
+ gen_init_special_pred(ModuleInfo,
+ CompareProcLabel, CompareExpr, !VarSet),
VarSet = !.VarSet
),
ELDSTypeCtorData = elds_tuple([
elds_term(elds_int(Arity)),
elds_term(elds_int(Version)),
- elds_term(elds_int(NumPtags)),
- elds_term(elds_atom_raw(TypeCtorRep)),
UnifyExpr,
CompareExpr,
elds_term(elds_string(sym_name_to_string(ModuleName))),
elds_term(elds_string(TypeName)),
- elds_term(elds_atom_raw("XXX TypeFunctors")),
- elds_term(elds_atom_raw("XXX TypeLayout")),
- elds_term(elds_int(NumFunctors)),
- elds_term(elds_int(encode_type_ctor_flags(Flags))),
- elds_term(elds_atom_raw("XXX FunctorNumberMap"))
+ erlang_type_ctor_rep(Details)
]),
RttiId = elds_rtti_type_ctor_id(ModuleName, TypeName, Arity),
IsExported = yes,
@@ -270,15 +439,72 @@
elds_clause([], elds_term(ELDSTypeCtorData))),
RttiDefns = [RttiDefn].
-:- pred gen_init_special_pred(module_info::in,
- univ::in, elds_expr::out, prog_varset::in, prog_varset::out) is det.
+:- func erlang_type_ctor_rep(erlang_type_ctor_details) = elds_expr.
+
+erlang_type_ctor_rep(erlang_du(_)) =
+ elds_term(make_enum_alternative("du")).
+erlang_type_ctor_rep(erlang_list(_)) =
+ elds_term(make_enum_alternative("list")).
+erlang_type_ctor_rep(erlang_eqv(_)) =
+ elds_term(make_enum_alternative("eqv")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_int)) =
+ elds_term(make_enum_alternative("int")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_float)) =
+ elds_term(make_enum_alternative("float")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_char)) =
+ elds_term(make_enum_alternative("char")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_string)) =
+ elds_term(make_enum_alternative("string")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_void)) =
+ elds_term(make_enum_alternative("void")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_c_pointer(is_stable))) =
+ elds_term(make_enum_alternative("stable_c_pointer")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_c_pointer(is_not_stable))) =
+ elds_term(make_enum_alternative("c_pointer")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pred_ctor)) =
+ elds_term(make_enum_alternative("pred")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_func_ctor)) =
+ elds_term(make_enum_alternative("func")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_tuple)) =
+ elds_term(make_enum_alternative("tuple")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_ref)) =
+ elds_term(make_enum_alternative("ref")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_desc)) =
+ elds_term(make_enum_alternative("type_desc")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pseudo_type_desc)) =
+ elds_term(make_enum_alternative("pseudo_type_desc")).
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_ctor_desc)) =
+ elds_term(make_enum_alternative("type_ctor_desc")).
+
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_hp)) =
+ elds_term(make_enum_alternative("hp")).
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_subgoal)) =
+ elds_term(make_enum_alternative("subgoal")).
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_ticket)) =
+ elds_term(make_enum_alternative("ticket")).
+
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_type_info)) =
+ elds_term(make_enum_alternative("type_info")).
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_type_ctor_info)) =
+ elds_term(make_enum_alternative("type_ctor_info")).
+erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_typeclass_info)) =
+ elds_term(make_enum_alternative("typeclass_info")).
+erlang_type_ctor_rep(
+ erlang_impl_artifact(erlang_impl_ctor_base_typeclass_info)) =
+ elds_term(make_enum_alternative("base_typeclass_info")).
+erlang_type_ctor_rep(erlang_foreign) =
+ elds_term(make_enum_alternative("foreign")).
+
-gen_init_special_pred(ModuleInfo, RttiProcIdUniv, Expr, !VarSet) :-
- ( univ_to_type(RttiProcIdUniv, RttiProcId) ->
+:- pred gen_init_special_pred(module_info::in, maybe(rtti_proc_label)::in,
+ elds_expr::out, prog_varset::in, prog_varset::out) is det.
+
+gen_init_special_pred(ModuleInfo, MaybeRttiProcId, Expr, !VarSet) :-
+ ( MaybeRttiProcId = yes(RttiProcId),
erl_gen_special_pred_wrapper(ModuleInfo, RttiProcId, Expr, !VarSet)
- ;
+ ; MaybeRttiProcId = no,
unexpected(this_file,
- "gen_init_special_pred: cannot extract univ value")
+ "gen_init_special_pred: no special pred")
).
:- pred erl_gen_special_pred_wrapper(module_info::in, rtti_proc_label::in,
Index: compiler/erlang_rtti.m
===================================================================
RCS file: compiler/erlang_rtti.m
diff -N compiler/erlang_rtti.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/erlang_rtti.m 31 May 2007 13:10:51 -0000
@@ -0,0 +1,171 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2007 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: erlang_rtti.m.
+% Authors: petdr, zs.
+%
+% Definitions of data structures for representing run-time type information
+% in the Erlang backend.
+%
+% Note we only define new types for from where the RTTI differs
+% from what is defined in rtti.m.
+%
+%-----------------------------------------------------------------------------%
+
+:- module backend_libs.erlang_rtti.
+:- interface.
+
+:- import_module backend_libs.rtti.
+:- import_module hlds.
+:- import_module hlds.hlds_rtti.
+:- import_module mdbcomp.
+:- import_module mdbcomp.prim_data.
+
+:- import_module list.
+:- import_module maybe.
+
+%-----------------------------------------------------------------------------%
+%
+% The data structures representing type constructors
+%
+
+ % A type_ctor_data structure contains all the information that the
+ % runtime system needs to know about a type constructor.
+ %
+:- type erlang_type_ctor_data
+ ---> erlang_type_ctor_data(
+ etcr_version :: int,
+ etcr_module_name :: module_name,
+ etcr_type_name :: string,
+ etcr_arity :: int,
+
+ %
+ % It is possible that the type doesn't have
+ % a unify or compare predicate.
+ % eg one cannot unify higher-order types.
+ %
+ etcr_unify :: maybe(rtti_proc_label),
+ etcr_compare :: maybe(rtti_proc_label),
+ etcr_rep_details :: erlang_type_ctor_details
+ ).
+
+ % A erlang_type_ctor_details structure contains all the information that
+ % the runtime system needs to know about the data representation scheme
+ % used by a type constructor.
+ %
+ % XXX Later on we may want to handle the enum and notag du types
+ % specially.
+ % Enum is for types that define only constants.
+ % Notag is for types that define only one unary functor.
+ %
+:- type erlang_type_ctor_details
+
+ ---> erlang_du(
+ % The function symbols are listed in declaration order.
+ edu_functors :: list(erlang_du_functor)
+ )
+
+ % Mercury lists are represented as erlang lists
+ ; erlang_list(
+ elist :: rtti_maybe_pseudo_type_info
+ )
+
+ ; erlang_eqv(
+ % XXX why is it a pseudo type info
+ eeqv_type :: rtti_maybe_pseudo_type_info
+ )
+
+ % Builtin Mercury types
+ ; erlang_builtin(
+ ebuiltin_ctor :: builtin_ctor
+ )
+
+
+ % Types used just in the implementation.
+ ; erlang_impl_artifact(
+ eimpl_ctor :: erlang_impl_ctor
+ )
+
+ ; erlang_foreign
+ .
+
+:- type erlang_du_functor
+ ---> erlang_du_functor(
+ edu_name :: string,
+ edu_orig_arity :: int,
+
+ % Size of the tuple needed to represent the
+ % functor.
+ edu_ordinal :: int,
+
+ % erlang atom which represents the functor
+ % currently encoded version of name
+ % in the future maybe name_arity
+ edu_rep :: string,
+ edu_arg_infos :: list(du_arg_info),
+ edu_exist_info :: maybe(exist_info)
+ ).
+
+ % The list of type constructors that are used behind the scenes by
+ % the Mercury implementation.
+ %
+:- type erlang_impl_ctor
+ ---> erlang_impl_ctor_type_info
+ ; erlang_impl_ctor_type_ctor_info
+ ; erlang_impl_ctor_typeclass_info
+ ; erlang_impl_ctor_base_typeclass_info
+
+ % The following are introduced in
+ % private_builtin and table_builtin
+ % but should never be used.
+ %
+ ; erlang_impl_ctor_hp
+ ; erlang_impl_ctor_subgoal
+ ; erlang_impl_ctor_ticket
+ .
+
+%-----------------------------------------------------------------------------%
+%
+% The data structures representing the top-level global data structures
+% generated by the Mercury compiler. These are all generated read-only.
+
+:- type erlang_rtti_data
+ ---> erlang_rtti_data_type_ctor_info(
+ erlang_type_ctor_data
+ )
+ ; erlang_rtti_data_type_info(
+ rtti_type_info
+ )
+ ; erlang_rtti_data_pseudo_type_info(
+ rtti_pseudo_type_info
+ )
+ ; erlang_rtti_data_base_typeclass_info(
+ tc_name, % identifies the type class
+ module_name, % module containing instance decl.
+ string, % encodes the names and arities of the
+ % types in the instance declaration
+ base_typeclass_info
+ )
+ ; erlang_rtti_data_type_class_decl(
+ tc_decl
+ )
+ ; erlang_rtti_data_type_class_instance(
+ tc_instance
+ ).
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- func this_file = string.
+
+this_file = "erlang_rtti.m".
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.437
diff -u -r1.437 mercury_compile.m
--- compiler/mercury_compile.m 28 May 2007 03:13:52 -0000 1.437
+++ compiler/mercury_compile.m 31 May 2007 13:10:54 -0000
@@ -5207,9 +5207,11 @@
list.append(OldTypeClassInfoRttiData, NewTypeClassInfoRttiData,
TypeClassInfoRttiData),
RttiDatas = TypeCtorRttiData ++ TypeClassInfoRttiData,
+ ErlangRttiDatas = list.map(erlang_rtti_data(HLDS), RttiDatas),
ELDS0 = elds(ModuleName, ForeignBodies, Defns, FEDefns, RttiDefns0),
- rtti_data_list_to_elds(HLDS, RttiDatas, RttiDefns),
+
+ rtti_data_list_to_elds(HLDS, ErlangRttiDatas, RttiDefns),
ELDS = elds(ModuleName, ForeignBodies, Defns, FEDefns,
RttiDefns0 ++ RttiDefns).
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.128
diff -u -r1.128 builtin.m
--- library/builtin.m 30 May 2007 08:16:02 -0000 1.128
+++ library/builtin.m 31 May 2007 13:10:56 -0000
@@ -594,6 +594,7 @@
:- implementation.
:- use_module rtti_implementation.
+:- use_module erlang_rtti_implementation.
call_rtti_generic_unify(X, Y) :-
rtti_implementation.generic_unify(X, Y).
@@ -810,9 +811,8 @@
'__Unify____c_pointer_0'(_, _) ->
throw(""called unify for type `c_pointer'"").
- % XXX TypeInfo ignored
compare_3_p_0(TypeInfo, X, Y) ->
- mercury__rtti_implementation:generic_compare_3_p_0(TypeInfo, X, Y).
+ mercury__erlang_rtti_implementation:generic_compare_3_p_0(TypeInfo, X, Y).
compare_3_p_1(TypeInfo, X, Y) ->
compare_3_p_0(TypeInfo, X, Y).
@@ -828,7 +828,7 @@
compare_3_p_0(TypeInfo, X, Y).
unify_2_p_0(TypeInfo, X, Y) ->
- mercury__rtti_implementation:generic_unify_2_p_0(TypeInfo, X, Y).
+ mercury__erlang_rtti_implementation:generic_unify_2_p_0(TypeInfo, X, Y).
'__Unify____tuple_0'(X, Y) ->
mercury__require:error_1_p_0(""call to unify for tuple/0"").
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: library/erlang_rtti_implementation.m
diff -N library/erlang_rtti_implementation.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/erlang_rtti_implementation.m 31 May 2007 13:10:56 -0000
@@ -0,0 +1,635 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2007 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: erlang_rtti_implementation.m.
+% Main author: petdr.
+% Stability: low.
+%
+% This file is intended to provide the RTTI implementation for the Erlang
+% backend.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module erlang_rtti_implementation.
+:- interface.
+
+ %
+ % Check if two values are equal.
+ % Note this is not structural equality because a type
+ % can have user-defined equality.
+ %
+:- pred generic_unify(T::in, T::in) is semidet.
+
+:- pred generic_compare(comparison_result::out, T::in, T::in) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+:- import_module require.
+:- import_module string.
+
+ %
+ % A type_info can be represented for one of three ways
+ % For a type with arity 0
+ % TypeCtorInfo
+ % a type with arity > 0
+ % { TypeCtorInfo, TypeInfo0, ..., TypeInfoN }
+ % a type with variable arity of size N
+ % { TypeCtorInfo, N, TypeCtorInfo0, ..., TypeCtorInfoN }
+ %
+:- type type_info.
+:- pragma foreign_type("Erlang", type_info, "").
+:- type type_info ---> type_info.
+
+ %
+ % For the representation of a type_ctor_info
+ % see erlang_rtti:type_ctor_data_to_elds
+ %
+:- type type_ctor_info.
+:- pragma foreign_type("Erlang", type_ctor_info, "").
+:- type type_ctor_info ---> type_ctor_info.
+
+ % The type_ctor_rep needs to be kept up to date with the alternatives
+ % given by the function erl_rtti.erlang_type_ctor_rep/1
+ %
+:- type erlang_type_ctor_rep
+ ---> du
+ ; list
+ ; eqv
+ ; int
+ ; float
+ ; char
+ ; string
+ ; void
+ ; stable_c_pointer
+ ; c_pointer
+ ; (pred)
+ ; (func)
+ ; tuple
+ ; ref
+ ; type_desc
+ ; pseudo_type_desc
+ ; type_ctor_desc
+ ; type_info
+ ; type_ctor_info
+ ; typeclass_info
+ ; base_typeclass_info
+ ; foreign
+
+ % These types shouldn't be needed they are
+ % introduced for library predicates which
+ % don't apply on this backend.
+ ; hp
+ ; subgoal
+ ; ticket
+ .
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+generic_unify(X, Y) :-
+ TypeInfo = X ^ type_info,
+ TypeCtorInfo = TypeInfo ^ type_ctor_info,
+ TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
+ (
+ TypeCtorRep = tuple
+ ->
+ unify_tuple(TypeInfo, X, Y)
+ ;
+ ( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
+ ->
+ error("unify/2: higher order unification not possible")
+ ;
+ Arity = TypeCtorInfo ^ type_ctor_arity,
+ UnifyPred = TypeCtorInfo ^ type_ctor_unify_pred,
+ ( Arity = 0 ->
+ semidet_call_3(UnifyPred, X, Y)
+ ; Arity = 1 ->
+ semidet_call_4(UnifyPred,
+ TypeInfo ^ type_info_index(1), X, Y)
+ ; Arity = 2 ->
+ semidet_call_5(UnifyPred,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ X, Y)
+ ; Arity = 3 ->
+ semidet_call_6(UnifyPred,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ X, Y)
+ ; Arity = 4 ->
+ semidet_call_7(UnifyPred,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ X, Y)
+ ; Arity = 5 ->
+ semidet_call_8(UnifyPred,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ TypeInfo ^ type_info_index(5),
+ X, Y)
+ ;
+ error("unify/2: type arity > 5 not supported")
+ )
+ ).
+
+:- pred unify_tuple(type_info::in, T::in, T::in) is semidet.
+
+unify_tuple(TypeInfo, X, Y) :-
+ Arity = TypeInfo ^ var_arity_type_info_arity,
+ unify_tuple_pos(1, Arity, TypeInfo, X, Y).
+
+:- pred unify_tuple_pos(int::in, int::in,
+ type_info::in, T::in, T::in) is semidet.
+
+unify_tuple_pos(Loc, TupleArity, TypeInfo, TermA, TermB) :-
+ ( Loc > TupleArity ->
+ true
+ ;
+ ArgTypeInfo = TypeInfo ^ var_arity_type_info_index(Loc),
+
+ SubTermA = get_subterm(ArgTypeInfo, TermA, Loc, 0),
+ SubTermB = get_subterm(ArgTypeInfo, TermB, Loc, 0),
+
+ generic_unify(SubTermA, unsafe_cast(SubTermB)),
+
+ unify_tuple_pos(Loc + 1, TupleArity, TypeInfo, TermA, TermB)
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+generic_compare(Res, X, Y) :-
+ TypeInfo = X ^ type_info,
+ TypeCtorInfo = TypeInfo ^ type_ctor_info,
+ TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
+ (
+ TypeCtorRep = tuple
+ ->
+ compare_tuple(TypeInfo, Res, X, Y)
+ ;
+ ( TypeCtorRep = (pred) ; TypeCtorRep = (func) )
+ ->
+ error("compare/3: higher order comparison not possible")
+ ;
+ Arity = TypeCtorInfo ^ type_ctor_arity,
+ ComparePred = TypeCtorInfo ^ type_ctor_compare_pred,
+ ( Arity = 0 ->
+ result_call_4(ComparePred, Res, X, Y)
+ ; Arity = 1 ->
+ result_call_5(ComparePred, Res,
+ TypeInfo ^ type_info_index(1), X, Y)
+ ; Arity = 2 ->
+ result_call_6(ComparePred, Res,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ X, Y)
+ ; Arity = 3 ->
+ result_call_7(ComparePred, Res,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ X, Y)
+ ; Arity = 4 ->
+ result_call_8(ComparePred, Res,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ X, Y)
+ ; Arity = 5 ->
+ result_call_9(ComparePred, Res,
+ TypeInfo ^ type_info_index(1),
+ TypeInfo ^ type_info_index(2),
+ TypeInfo ^ type_info_index(3),
+ TypeInfo ^ type_info_index(4),
+ TypeInfo ^ type_info_index(5),
+ X, Y)
+ ;
+ error("compare/3: type arity > 5 not supported")
+ )
+ ).
+
+:- pred compare_tuple(type_info::in, comparison_result::out, T::in, T::in)
+ is det.
+
+compare_tuple(TypeInfo, Result, TermA, TermB) :-
+ Arity = TypeInfo ^ var_arity_type_info_arity,
+ compare_tuple_pos(1, Arity, TypeInfo, Result, TermA, TermB).
+
+:- pred compare_tuple_pos(int::in, int::in, type_info::in,
+ comparison_result::out, T::in, T::in) is det.
+
+compare_tuple_pos(Loc, TupleArity, TypeInfo, Result, TermA, TermB) :-
+ ( Loc > TupleArity ->
+ Result = (=)
+ ;
+ ArgTypeInfo = TypeInfo ^ var_arity_type_info_index(Loc),
+
+ SubTermA = get_subterm(ArgTypeInfo, TermA, Loc, 0),
+ SubTermB = get_subterm(ArgTypeInfo, TermB, Loc, 0),
+
+ generic_compare(SubResult, SubTermA, unsafe_cast(SubTermB)),
+ ( SubResult = (=) ->
+ compare_tuple_pos(Loc + 1, TupleArity, TypeInfo, Result,
+ TermA, TermB)
+ ;
+ Result = SubResult
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_code("Erlang", "
+ % Location of element in a type_info
+ ti_type_ctor_info() -> 1.
+ ti_var_arity() -> 2.
+
+ % Location of elements in a type_ctor_info
+ tci_arity() -> 1.
+ tci_version() -> 2.
+ tci_unify_pred() -> 3.
+ tci_compare_pred() -> 4.
+ tci_module_name() -> 5.
+ tci_type_name() -> 6.
+ tci_type_ctor_rep() -> 7.
+ tci_functors() -> 8.
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func type_info(T::unused) = (type_info::out) is det.
+
+:- pragma foreign_proc("Erlang",
+ type_info(_T::unused) = (TypeInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeInfo = TypeInfo_for_T
+").
+
+type_info(_) = type_info :-
+ det_unimplemented("type_info").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func type_ctor_info(type_info) = type_ctor_info.
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ %
+ % If the type_info is for a type with arity 0,
+ % then the type_info is already the type_ctor info.
+ % The first field of a type_ctor_info is the integer
+ % zero in this case.
+ %
+ FirstElement = element(ti_type_ctor_info(), TypeInfo),
+ if
+ % XXX is the test FirstElement =:= 0 better?
+ is_integer(FirstElement)
+ -> TypeCtorInfo = TypeInfo ;
+ true
+ -> TypeCtorInfo = FirstElement
+ end
+").
+
+type_ctor_info(_) = type_ctor_info :-
+ det_unimplemented("type_ctor_info").
+
+:- func var_arity_type_info_arity(type_info) = int.
+
+:- pragma foreign_proc("Erlang",
+ var_arity_type_info_arity(TypeInfo::in) = (TypeCtorInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeCtorInfo = element(ti_var_arity(), TypeInfo)
+").
+
+var_arity_type_info_arity(_) = 0 :-
+ det_unimplemented("var_arity_type_info_arity").
+
+ %
+ % TI ^ type_info_index(I)
+ %
+ % returns the I'th type_info from the given standard type_info TI.
+ % NOTE indexes start at one.
+ %
+:- func type_info_index(int, type_info) = type_info.
+
+type_info_index(I, TI) = TI ^ unsafe_type_info_index(I + 1).
+
+ %
+ % TI ^ var_arity_type_info_index(I)
+ %
+ % returns the I'th type_info from the given variable arity type_info TI.
+ % NOTE indexes start at one.
+ %
+:- func var_arity_type_info_index(int, type_info) = type_info.
+
+var_arity_type_info_index(I, TI) = TI ^ unsafe_type_info_index(I + 2).
+
+ %
+ % Use type_info_index or var_arity_type_info_index, never this predicate
+ % directly.
+ %
+:- func unsafe_type_info_index(int, type_info) = type_info.
+
+:- pragma foreign_proc("Erlang",
+ unsafe_type_info_index(Index::in, TypeInfo::in) = (SubTypeInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SubTypeInfo = element(Index, TypeInfo)
+").
+
+unsafe_type_info_index(_, _) = type_info :-
+ det_unimplemented("unsafe_type_info_index").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- func type_ctor_rep(type_ctor_info) = erlang_type_ctor_rep.
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeCtorRep = element(tci_type_ctor_rep(), TypeCtorInfo)
+").
+
+type_ctor_rep(_) = _ :-
+ % This version is only used for back-ends for which there is no
+ % matching foreign_proc version.
+ private_builtin.sorry("type_ctor_rep").
+
+:- some [P] func type_ctor_unify_pred(type_ctor_info) = P.
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % The TypeInfo is never used so this is safe
+ TypeInfo_for_P = 0,
+ UnifyPred = element(tci_unify_pred(), TypeCtorInfo)
+").
+
+type_ctor_unify_pred(_) = "dummy value" :-
+ det_unimplemented("type_ctor_unify_pred").
+
+:- some [P] func type_ctor_compare_pred(type_ctor_info) = P.
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_compare_pred(TypeCtorInfo::in) = (ComparePred::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % The TypeInfo is never used so this is safe
+ TypeInfo_for_P = 0,
+ ComparePred = element(tci_compare_pred(), TypeCtorInfo)
+").
+
+type_ctor_compare_pred(_) = "dummy value" :-
+ det_unimplemented("type_ctor_compare_pred").
+
+:- func type_ctor_arity(type_ctor_info) = int.
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Arity = element(tci_arity(), TypeCtorInfo)
+").
+
+type_ctor_arity(_) = 0 :-
+ det_unimplemented("type_ctor_arity").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % Get a subterm term, given its type_info, the original term, its index
+ % and the start region size.
+ %
+:- some [T] func get_subterm(type_info, U, int, int) = T.
+
+get_subterm(_::in, _::in, _::in, _::in) = (42::out) :-
+ det_unimplemented("get_subterm").
+
+:- pragma foreign_proc("Erlang",
+ get_subterm(TypeInfo::in, Term::in, Index::in, ExtraArgs::in) = (Arg::out),
+ [promise_pure],
+"
+ % TypeInfo_for_U to avoid compiler warning
+ TypeInfo_for_T = TypeInfo,
+ Arg = element(Index + ExtraArgs, Term)
+").
+
+:- func unsafe_cast(T) = U.
+
+:- pragma foreign_proc("Erlang",
+ unsafe_cast(VarIn::in) = (VarOut::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ VarOut = VarIn
+").
+
+unsafe_cast(_) = _ :-
+ % This version is only used for back-ends for which there is no
+ % matching foreign_proc version.
+ private_builtin.sorry("unsafe_cast").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % Implement generic calls -- we could use call/N but then we would
+ % have to create a real closure.
+ %
+ % We first give "unimplemented" definitions in Mercury, which will be
+ % used by default.
+
+:- pred semidet_call_3(P::in, T::in, U::in) is semidet.
+semidet_call_3(_::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_3").
+
+:- pred semidet_call_4(P::in, A::in, T::in, U::in) is semidet.
+semidet_call_4(_::in, _::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_4").
+
+:- pred semidet_call_5(P::in, A::in, B::in, T::in, U::in) is semidet.
+semidet_call_5(_::in, _::in, _::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_5").
+
+:- pred semidet_call_6(P::in, A::in, B::in, C::in, T::in, U::in) is semidet.
+semidet_call_6(_::in, _::in, _::in, _::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_6").
+
+:- pred semidet_call_7(P::in, A::in, B::in, C::in, D::in, T::in, U::in)
+ is semidet.
+semidet_call_7(_::in, _::in, _::in, _::in, _::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_7").
+
+:- pred semidet_call_8(P::in, A::in, B::in, C::in, D::in, E::in, T::in, U::in)
+ is semidet.
+semidet_call_8(_::in, _::in, _::in, _::in, _::in, _::in, _::in, _::in) :-
+ semidet_unimplemented("semidet_call_8").
+
+:- pred result_call_4(P::in, comparison_result::out,
+ T::in, U::in) is det.
+result_call_4(_::in, (=)::out, _::in, _::in) :-
+ det_unimplemented("result_call_4").
+
+:- pred result_call_5(P::in, comparison_result::out,
+ A::in, T::in, U::in) is det.
+result_call_5(_::in, (=)::out, _::in, _::in, _::in) :-
+ det_unimplemented("comparison_result").
+
+:- pred result_call_6(P::in, comparison_result::out,
+ A::in, B::in, T::in, U::in) is det.
+result_call_6(_::in, (=)::out, _::in, _::in, _::in, _::in) :-
+ det_unimplemented("comparison_result").
+
+:- pred result_call_7(P::in, comparison_result::out,
+ A::in, B::in, C::in, T::in, U::in) is det.
+result_call_7(_::in, (=)::out, _::in, _::in, _::in, _::in, _::in) :-
+ det_unimplemented("comparison_result").
+
+:- pred result_call_8(P::in, comparison_result::out,
+ A::in, B::in, C::in, D::in, T::in, U::in) is det.
+result_call_8(_::in, (=)::out, _::in, _::in, _::in, _::in, _::in, _::in) :-
+ det_unimplemented("comparison_result").
+
+:- pred result_call_9(P::in, comparison_result::out,
+ A::in, B::in, C::in, D::in, E::in, T::in, U::in) is det.
+result_call_9(_::in, (=)::out, _::in, _::in, _::in, _::in, _::in,
+ _::in, _::in) :-
+ det_unimplemented("result_call_9").
+
+:- pred semidet_unimplemented(string::in) is semidet.
+
+semidet_unimplemented(S) :-
+ ( semidet_succeed ->
+ error("rtti_implementation: unimplemented: " ++ S)
+ ;
+ semidet_succeed
+ ).
+
+:- pred det_unimplemented(string::in) is det.
+
+det_unimplemented(S) :-
+ ( semidet_succeed ->
+ error("rtti_implementation: unimplemented: " ++ S)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ % We override the above definitions in the .NET backend.
+
+:- pragma foreign_proc("Erlang",
+ semidet_call_3(Pred::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_4(Pred::in, A::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(A, X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_5(Pred::in, A::in, B::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(A, B, X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_6(Pred::in, A::in, B::in, C::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_7(Pred::in, A::in, B::in, C::in, D::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, D, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_8(Pred::in, A::in, B::in, C::in, D::in, E::in,
+ X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, D, E, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+
+:- pragma foreign_proc("Erlang",
+ result_call_4(Pred::in, Res::out, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(X, Y)
+").
+
+:- pragma foreign_proc("Erlang",
+ result_call_5(Pred::in, Res::out, A::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_6(Pred::in, Res::out, A::in, B::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_7(Pred::in, Res::out, A::in, B::in, C::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_8(Pred::in, Res::out, A::in, B::in, C::in, D::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, D, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_9(Pred::in, Res::out, A::in, B::in, C::in, D::in, E::in,
+ X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, D, E, X, Y)
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: library/library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/library.m,v
retrieving revision 1.105
diff -u -r1.105 library.m
--- library/library.m 30 May 2007 02:47:08 -0000 1.105
+++ library/library.m 31 May 2007 13:10:56 -0000
@@ -66,6 +66,7 @@
:- import_module dir.
:- import_module enum.
:- import_module eqvclass.
+:- import_module erlang_rtti_implementation.
:- import_module exception.
:- import_module float.
:- import_module gc.
@@ -210,6 +211,7 @@
mercury_std_library_module("dir").
mercury_std_library_module("enum").
mercury_std_library_module("eqvclass").
+mercury_std_library_module("erlang_rtti_implementation").
mercury_std_library_module("exception").
mercury_std_library_module("float").
mercury_std_library_module("gc").
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.76
diff -u -r1.76 rtti_implementation.m
--- library/rtti_implementation.m 30 May 2007 08:16:07 -0000 1.76
+++ library/rtti_implementation.m 31 May 2007 13:10:57 -0000
@@ -436,13 +436,6 @@
TypeInfo = TypeInfo_for_T;
").
-:- pragma foreign_proc("Erlang",
- get_type_info(_T::unused) = (TypeInfo::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeInfo = TypeInfo_for_T
-").
-
get_type_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -781,100 +774,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
- % We override the above definitions in the .NET backend.
-
-:- pragma foreign_proc("Erlang",
- semidet_call_3(Pred::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR = case Pred(X, Y) of {} -> true; fail -> false end
-").
-:- pragma foreign_proc("Erlang",
- semidet_call_4(Pred::in, A::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR = case Pred(A, X, Y) of {} -> true; fail -> false end
-").
-:- pragma foreign_proc("Erlang",
- semidet_call_5(Pred::in, A::in, B::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR = case Pred(A, B, X, Y) of {} -> true; fail -> false end
-").
-:- pragma foreign_proc("Erlang",
- semidet_call_6(Pred::in, A::in, B::in, C::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR =
- case Pred(A, B, C, X, Y) of
- {} -> true;
- fail -> false
- end
-").
-:- pragma foreign_proc("Erlang",
- semidet_call_7(Pred::in, A::in, B::in, C::in, D::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR =
- case Pred(A, B, C, D, X, Y) of
- {} -> true;
- fail -> false
- end
-").
-:- pragma foreign_proc("Erlang",
- semidet_call_8(Pred::in, A::in, B::in, C::in, D::in, E::in,
- X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR =
- case Pred(A, B, C, D, E, X, Y) of
- {} -> true;
- fail -> false
- end
-").
-
-:- pragma foreign_proc("Erlang",
- result_call_4(Pred::in, Res::out, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(X, Y)
-").
-
-:- pragma foreign_proc("Erlang",
- result_call_5(Pred::in, Res::out, A::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(A, X, Y)
-").
-:- pragma foreign_proc("Erlang",
- result_call_6(Pred::in, Res::out, A::in, B::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(A, B, X, Y)
-").
-:- pragma foreign_proc("Erlang",
- result_call_7(Pred::in, Res::out, A::in, B::in, C::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(A, B, C, X, Y)
-").
-:- pragma foreign_proc("Erlang",
- result_call_8(Pred::in, Res::out, A::in, B::in, C::in, D::in, X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(A, B, C, D, X, Y)
-").
-:- pragma foreign_proc("Erlang",
- result_call_9(Pred::in, Res::out, A::in, B::in, C::in, D::in, E::in,
- X::in, Y::in),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- {Res} = Pred(A, B, C, D, E, X, Y)
-").
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
compare_type_infos(Res, TypeInfo1, TypeInfo2) :-
( same_pointer_value(TypeInfo1, TypeInfo2) ->
Res = (=)
@@ -1723,22 +1622,6 @@
:- func get_type_ctor_info(type_info) = type_ctor_info is det.
-:- pragma foreign_code("Erlang", "
- % field numbers for type_ctor_infos
- type_ctor_arity() -> 1.
- type_ctor_version() -> 2.
- type_ctor_num_ptags() -> 3.
- type_ctor_rep() -> 4.
- type_ctor_unify_pred() -> 5.
- type_ctor_compare_pred() -> 6.
- type_ctor_module_name() -> 7.
- type_ctor_name() -> 8.
- type_functors() -> 9.
- type_layout() -> 10.
- type_ctor_num_functors() -> 11.
- type_ctor_flags() -> 12.
-").
-
:- pragma foreign_code("C#", "
// The field numbers of the contents of type_infos.
@@ -1830,13 +1713,6 @@
(MR_TypeInfo) TypeInfo);
").
-:- pragma foreign_proc("Erlang",
- get_type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeCtorInfo = element(1, TypeInfo)
-").
-
get_type_ctor_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2137,13 +2013,6 @@
TypeInfoAtIndex = (object[]) TypeInfo[X];
").
-:- pragma foreign_proc("Erlang",
- type_info_index(X::in, TypeInfo::in) = (TypeInfoAtIndex::out),
- [will_not_call_mercury, promise_pure],
-"
- TypeInfoAtIndex = element(X + 1, TypeInfo)
-").
-
:- pred update_type_info_index(int::in, type_info::in, type_info::di,
type_info::uo) is det.
@@ -2201,12 +2070,6 @@
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
Arity = tci->MR_type_ctor_arity;
").
-:- pragma foreign_proc("Erlang",
- type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- Arity = element(type_ctor_arity(), TypeCtorInfo)
-").
type_ctor_arity(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2235,14 +2098,6 @@
tci = (MR_TypeCtorInfo) TypeCtorInfo;
UnifyPred = (MR_Integer) tci->MR_type_ctor_unify_pred;
").
-:- pragma foreign_proc("Erlang",
- type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- % XXX This should be something else.
- TypeInfo_for_P = 0,
- UnifyPred = element(type_ctor_unify_pred(), TypeCtorInfo)
-").
type_ctor_unify_pred(_) = "dummy value" :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2302,61 +2157,6 @@
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
TypeCtorRep = MR_type_ctor_rep(tci);
").
-:- pragma foreign_proc("Erlang",
- type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- TypeCtorRep =
- case element(type_ctor_rep(), TypeCtorInfo) of
- 'MR_TYPECTOR_REP_ENUM' -> {tcr_enum};
- 'MR_TYPECTOR_REP_ENUM_USEREQ' -> {tcr_enum_usereq};
- 'MR_TYPECTOR_REP_DU' -> {tcr_du};
- 'MR_TYPECTOR_REP_DU_USEREQ' -> {tcr_du_usereq};
- 'MR_TYPECTOR_REP_NOTAG' -> {tcr_notag};
- 'MR_TYPECTOR_REP_NOTAG_USEREQ' -> {tcr_notag_usereq};
- 'MR_TYPECTOR_REP_EQUIV' -> {tcr_equiv};
- 'MR_TYPECTOR_REP_FUNC' -> {tcr_func};
- 'MR_TYPECTOR_REP_INT' -> {tcr_int};
- 'MR_TYPECTOR_REP_CHAR' -> {tcr_char};
- 'MR_TYPECTOR_REP_FLOAT' -> {tcr_float};
- 'MR_TYPECTOR_REP_STRING' -> {tcr_string};
- 'MR_TYPECTOR_REP_PRED' -> {tcr_pred};
- 'MR_TYPECTOR_REP_SUBGOAL' -> {tcr_subgoal};
- 'MR_TYPECTOR_REP_VOID' -> {tcr_void};
- 'MR_TYPECTOR_REP_C_POINTER' -> {tcr_c_pointer};
- 'MR_TYPECTOR_REP_TYPEINFO' -> {tcr_typeinfo};
- 'MR_TYPECTOR_REP_TYPECLASSINFO' -> {tcr_typeclassinfo};
- 'MR_TYPECTOR_REP_ARRAY' -> {tcr_array};
- 'MR_TYPECTOR_REP_SUCCIP' -> {tcr_succip};
- 'MR_TYPECTOR_REP_HP' -> {tcr_hp};
- 'MR_TYPECTOR_REP_CURFR' -> {tcr_curfr};
- 'MR_TYPECTOR_REP_MAXFR' -> {tcr_maxfr};
- 'MR_TYPECTOR_REP_REDOFR' -> {tcr_redofr};
- 'MR_TYPECTOR_REP_REDOIP' -> {tcr_redoip};
- 'MR_TYPECTOR_REP_TRAIL_PTR' -> {tcr_trail_ptr};
- 'MR_TYPECTOR_REP_TICKET' -> {tcr_ticket};
- 'MR_TYPECTOR_REP_NOTAG_GROUND' -> {tcr_notag_ground};
- 'MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ' -> {tcr_notag_ground_usereq};
- 'MR_TYPECTOR_REP_EQUIV_GROUND' -> {tcr_equiv_ground};
- 'MR_TYPECTOR_REP_TUPLE' -> {tcr_tuple};
- 'MR_TYPECTOR_REP_RESERVED_ADDR' -> {tcr_reserved_addr};
- 'MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ' -> {tcr_reserved_addr_usereq};
- 'MR_TYPECTOR_REP_TYPECTORINFO' -> {tcr_type_ctor_info};
- 'MR_TYPECTOR_REP_BASETYPECLASSINFO' -> {tcr_base_typeclass_info};
- 'MR_TYPECTOR_REP_TYPEDESC' -> {tcr_type_desc};
- 'MR_TYPECTOR_REP_TYPECTORDESC' -> {tcr_type_ctor_desc};
- 'MR_TYPECTOR_REP_FOREIGN' -> {tcr_foreign};
- 'MR_TYPECTOR_REP_REFERENCE' -> {tcr_reference};
- 'MR_TYPECTOR_REP_STABLE_C_POINTER' -> {tcr_stable_c_pointer};
- 'MR_TYPECTOR_REP_STABLE_FOREIGN' -> {tcr_stable_foreign};
- 'MR_TYPECTOR_REP_PSEUDOTYPEDESC' -> {tcr_pseudo_type_desc};
- 'MR_TYPECTOR_REP_DUMMY' -> {tcr_dummy};
- 'MR_TYPECTOR_REP_BITMAP' -> {tcr_bitmap};
- _ -> {tcr_unknown}
- end
-").
-
-
type_ctor_rep(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2502,12 +2302,6 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
VarOut = VarIn;
-").
-:- pragma foreign_proc("Erlang",
- unsafe_cast(VarIn::in) = (VarOut::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- VarOut = VarIn
").
unsafe_cast(_) = _ :-
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list