[m-rev.] for review: implement deconstruct of du types for Erlang backend
Peter Ross
pro at missioncriticalit.com
Mon Jun 4 16:53:06 AEST 2007
Peter Wang,
Can you have a look at this?
===================================================================
Estimated hours taken: 8
Branches: main
Implement the RTTI for calling deconstruct on du types.
compiler/erl_rtti.m:
Fix a bug where we gave the incorrect arity of notag functors.
Give the correct ordinal to enum and du functors.
Rewrite rtti_type_info_to_elds and rtti_pseudo_type_info_to_elds
so that we no longer generate code which causes an infinite loop
when constructing these types.
Represent functors of a du type
as the list(erlang_rtti_implementaiton.erlang_du_functor) in the
RTTI.
Rename convert_to_elds_term to rtti_elds_expr and adapt the code
so that it can be passed erlang_du_functors and generate the correct
representation.
compiler/erl_unify_gen.m:
Add a comment about a case where we generate unifications which
the RTTI deconstruct code can't deal with correctly.
compiler/erlang_rtti.m:
Fix up the documentation on edu_ordinal.
Change edu_rep to be a distinct type so that rtti_to_elds_expr
can handle this part of the erlang_du_functor specially.
library/erlang_rtti_implementation.m:
Make a "copy" of the erlang_du_functor type and all the associated
types.
Interpret the new erlang_du_functor type so that we can
deconstruct du types.
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.7
diff -u -r1.7 erl_rtti.m
--- compiler/erl_rtti.m 1 Jun 2007 06:05:43 -0000 1.7
+++ compiler/erl_rtti.m 4 Jun 2007 06:40:58 -0000
@@ -165,7 +165,8 @@
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),
+ DUFunctor =
+ erlang_du_functor(Name, 1, 1, erlang_atom_raw(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).
@@ -178,8 +179,8 @@
%
:- func convert_enum_functor(enum_functor) = erlang_du_functor.
-convert_enum_functor(enum_functor(Name, _)) =
- erlang_du_functor(Name, 0, 1, Name, [], no).
+convert_enum_functor(enum_functor(Name, Ordinal)) =
+ erlang_du_functor(Name, 0, Ordinal, erlang_atom_raw(Name), [], no).
%
% Convert a du_functor into the equivalent erlang_du_functor
@@ -187,7 +188,8 @@
:- 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).
+ erlang_du_functor(Name, Arity,
+ Ordinal, erlang_atom_raw(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.
@@ -387,53 +389,51 @@
:- pred rtti_type_info_to_elds(module_info::in, rtti_type_info::in,
list(elds_rtti_defn)::out) is det.
-rtti_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = plain_arity_zero_type_info(RttiTypeCtor),
-
- TypeCtorRttiId = elds_rtti_type_ctor_id(RttiTypeCtor),
- ELDSTypeInfo = elds_rtti_ref(TypeCtorRttiId),
-
- RttiId = elds_rtti_type_info_id(TypeInfo),
- IsExported = no,
- RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], ELDSTypeInfo)),
-
- RttiDefns = [RttiDefn].
-
rtti_type_info_to_elds(ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = plain_type_info(TypeCtor, ArgTypeInfos),
-
- rtti_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
+ (
+ TypeInfo = plain_arity_zero_type_info(RttiTypeCtor),
- ELDSTypeInfo = elds_tuple(
- [elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)) | ELDSArgTypeInfos]),
+ TypeCtorRttiId = elds_rtti_type_ctor_id(RttiTypeCtor),
+ ELDSTypeInfo = elds_rtti_ref(TypeCtorRttiId),
- RttiId = elds_rtti_type_info_id(TypeInfo),
- IsExported = no,
- RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], elds_term(ELDSTypeInfo))),
+ ArgRttiDefns = []
+ ;
+ TypeInfo = plain_type_info(TypeCtor, ArgTypeInfos),
- RttiDefns = [RttiDefn | ArgRttiDefns ].
+ rtti_type_info_to_elds_2(ModuleInfo,
+ ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
-rtti_type_info_to_elds(ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = var_arity_type_info(VarCtorId, ArgTypeInfos),
- TypeCtor = var_arity_id_to_rtti_type_ctor(VarCtorId),
+ ELDSTypeInfo = elds_term(elds_tuple([
+ elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)) |
+ ELDSArgTypeInfos]))
+ ;
+ TypeInfo = var_arity_type_info(VarCtorId, ArgTypeInfos),
+ TypeCtor = var_arity_id_to_rtti_type_ctor(VarCtorId),
- rtti_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
+ rtti_type_info_to_elds_2(ModuleInfo,
+ ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
- ELDSTypeInfo = elds_tuple([
- elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)),
- elds_term(elds_int(list.length(ArgTypeInfos))) |
- ELDSArgTypeInfos]),
+ ELDSTypeInfo = elds_term(elds_tuple([
+ elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)),
+ elds_term(elds_int(list.length(ArgTypeInfos))) |
+ ELDSArgTypeInfos]))
+ ),
+ %
+ % A type_info can contain a call to construct a type_ctor_info
+ % which requires this type_info, leading to infinite recursion,
+ % we break this recursion by creating a closure which will
+ % evaluate to the type_info, if the type_info is needed.
+ %
+ ELDSFun = elds_fun(elds_clause([], ELDSTypeInfo)),
+
RttiId = elds_rtti_type_info_id(TypeInfo),
IsExported = no,
RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], elds_term(ELDSTypeInfo))),
+ elds_clause([], ELDSFun)),
+
+ RttiDefns = [RttiDefn | ArgRttiDefns].
- RttiDefns = [RttiDefn | ArgRttiDefns ].
:- pred rtti_type_info_to_elds_2(module_info::in,
list(rtti_type_info)::in,
@@ -457,65 +457,55 @@
:- pred rtti_pseudo_type_info_to_elds(module_info::in,
rtti_pseudo_type_info::in, list(elds_rtti_defn)::out) is det.
-rtti_pseudo_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = plain_arity_zero_pseudo_type_info(RttiTypeCtor),
-
- TypeCtorRttiId = elds_rtti_type_ctor_id(RttiTypeCtor),
- ELDSTypeInfo = elds_rtti_ref(TypeCtorRttiId),
-
- RttiId = elds_rtti_pseudo_type_info_id(TypeInfo),
- IsExported = no,
- RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], ELDSTypeInfo)),
-
- RttiDefns = [RttiDefn].
-
rtti_pseudo_type_info_to_elds(ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = plain_pseudo_type_info(TypeCtor, ArgTypeInfos),
-
- rtti_pseudo_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
-
- ELDSTypeInfo = elds_tuple(
- [elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)) | ELDSArgTypeInfos]),
-
- RttiId = elds_rtti_pseudo_type_info_id(TypeInfo),
- IsExported = no,
- RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], elds_term(ELDSTypeInfo))),
+ (
+ TypeInfo = plain_arity_zero_pseudo_type_info(RttiTypeCtor),
- RttiDefns = [RttiDefn | ArgRttiDefns ].
+ TypeCtorRttiId = elds_rtti_type_ctor_id(RttiTypeCtor),
+ ELDSTypeInfo = elds_rtti_ref(TypeCtorRttiId),
-rtti_pseudo_type_info_to_elds(ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = var_arity_pseudo_type_info(VarCtorId, ArgTypeInfos),
- TypeCtor = var_arity_id_to_rtti_type_ctor(VarCtorId),
+ ArgRttiDefns = []
+ ;
- rtti_pseudo_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
+ TypeInfo = plain_pseudo_type_info(TypeCtor, ArgTypeInfos),
- ELDSTypeInfo = elds_tuple([
- elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)),
- elds_term(elds_int(list.length(ArgTypeInfos))) |
- ELDSArgTypeInfos]),
+ rtti_pseudo_type_info_to_elds_2(ModuleInfo,
+ ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
- RttiId = elds_rtti_pseudo_type_info_id(TypeInfo),
- IsExported = no,
- RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], elds_term(ELDSTypeInfo))),
+ ELDSTypeInfo = elds_term(elds_tuple([
+ elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)) |
+ ELDSArgTypeInfos]))
+ ;
+ TypeInfo = var_arity_pseudo_type_info(VarCtorId, ArgTypeInfos),
+ TypeCtor = var_arity_id_to_rtti_type_ctor(VarCtorId),
- RttiDefns = [RttiDefn | ArgRttiDefns ].
+ rtti_pseudo_type_info_to_elds_2(ModuleInfo,
+ ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
-rtti_pseudo_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
- TypeInfo = type_var(I),
+ ELDSTypeInfo = elds_term(elds_tuple([
+ elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)),
+ elds_term(elds_int(list.length(ArgTypeInfos))) |
+ ELDSArgTypeInfos]))
+ ;
+ TypeInfo = type_var(I),
+ ELDSTypeInfo = elds_term(elds_int(I)),
+ ArgRttiDefns = []
+ ),
- ELDSTypeInfo = elds_int(I),
+ %
+ % A pseudo_type_info can contain a call to construct a type_ctor_info
+ % which requires this pseudo_type_info, leading to infinite recursion.
+ % We break this recursion by creating a closure which will
+ % evaluate to the pseudo_type_info, if the type_info is needed.
+ %
+ ELDSFun = elds_fun(elds_clause([], ELDSTypeInfo)),
RttiId = elds_rtti_pseudo_type_info_id(TypeInfo),
IsExported = no,
RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
- elds_clause([], elds_term(ELDSTypeInfo))),
+ elds_clause([], ELDSFun)),
- RttiDefns = [RttiDefn].
+ RttiDefns = [RttiDefn | ArgRttiDefns].
:- pred rtti_pseudo_type_info_to_elds_2(module_info::in,
list(rtti_maybe_pseudo_type_info)::in,
@@ -731,9 +721,7 @@
erlang_type_ctor_details(ModuleInfo, Details, Term, Defns) :-
(
Details = erlang_du(Functors),
- list.map_foldl(erlang_du_functor(ModuleInfo),
- Functors, ELDSFunctors, [], Defns),
- Term = elds_term(elds_tuple(ELDSFunctors))
+ rtti_to_elds_expr(ModuleInfo, Functors, Term, [], Defns)
;
Details = erlang_eqv(MaybePseudoTypeInfo),
maybe_pseudo_type_info_to_elds(ModuleInfo, MaybePseudoTypeInfo,
@@ -751,42 +739,92 @@
).
-:- pred erlang_du_functor(module_info::in, erlang_du_functor::in,
- elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-erlang_du_functor(ModuleInfo, Functor, elds_term(Term), !Defns) :-
- Functor = erlang_du_functor(Name, Arity, Ord, Rep, ArgInfos, MaybeExist),
+:- import_module deconstruct.
+:- import_module exception.
- list.map_foldl(du_arg_info(ModuleInfo), ArgInfos, ELDSArgInfos, !Defns),
- ELDSExist = convert_to_elds_term(MaybeExist),
+ %
+ % rtti_to_elds_expr(MI, T, Expr, !Defns)
+ %
+ % Given some T which is a representation of the RTTI data,
+ % it generates the elds_expr which would represent that T as an erlang
+ % term.
+ %
+ % It specially handles the types
+ % * erlang_atom_raw
+ % * rtti_maybe_pseudo_type_info
+ % * rtti_maybe_pseudo_type_info_or_self
+ %
+:- pred rtti_to_elds_expr(module_info::in, T::in, elds_expr::out,
+ list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
- Term = elds_tuple([
- elds_term(elds_string(Name)),
- elds_term(elds_int(Arity)),
- elds_term(elds_int(Ord)),
- elds_term(elds_atom_raw(Rep)),
- elds_term(elds_tuple(ELDSArgInfos)),
- elds_term(ELDSExist)
- ]).
-:- pred du_arg_info(module_info::in, du_arg_info::in,
+rtti_to_elds_expr(MI, Term, ELDS, !Defns) :-
+ ( dynamic_cast(Term, Int) ->
+ ELDS = elds_term(elds_int(Int))
+ ; dynamic_cast(Term, Char) ->
+ ELDS = elds_term(elds_char(Char))
+ ; dynamic_cast(Term, String) ->
+ ELDS = elds_term(elds_string(String))
+ ; dynamic_cast(Term, Float) ->
+ ELDS = elds_term(elds_float(Float))
+
+ %
+ % The RTTI types which have to be handled specially.
+ %
+ ; dynamic_cast(Term, Atom) ->
+ Atom = erlang_atom_raw(S),
+ ELDS = elds_term(elds_atom_raw(S))
+ ; dynamic_cast(Term, MaybePseudoTypeInfo) ->
+ convert_maybe_pseudo_type_info_to_elds(MI,
+ MaybePseudoTypeInfo, ELDS, !Defns)
+ ; dynamic_cast(Term, MaybePseudoTypeInfoOrSelf) ->
+ convert_maybe_pseudo_type_info_or_self_to_elds(MI,
+ MaybePseudoTypeInfoOrSelf, ELDS, !Defns)
+
+ ;
+ functor(Term, do_not_allow, Functor, Arity),
+
+ list.map_foldl(convert_arg_to_elds_expr(MI, Term),
+ 0 .. (Arity - 1), Exprs, !Defns),
+
+ ( Functor = "{}" ->
+ ELDS = elds_term(elds_tuple(Exprs))
+ ;
+ FunctorTerm = elds_term(elds_atom(unqualified(Functor))),
+ ELDS = elds_term(elds_tuple([FunctorTerm | Exprs]))
+ )
+ ).
+
+:- pred convert_arg_to_elds_expr(module_info::in, T::in, int::in,
elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
-du_arg_info(ModuleInfo, du_arg_info(MaybeName, TI), elds_term(Term), !Defns) :-
- (
- MaybeName = yes(Name),
- NameTerm = elds_string(Name)
+convert_arg_to_elds_expr(MI, Term, Index, ELDS, !Defns) :-
+ ( arg(Term, do_not_allow, Index, Arg) ->
+ rtti_to_elds_expr(MI, Arg, ELDS, !Defns)
;
- MaybeName = no,
- NameTerm = elds_tuple([])
- ),
- maybe_pseudo_type_info_or_self_to_elds(ModuleInfo, TI, RttiId, Defns),
+ unexpected(this_file, "convert_arg_to_elds_expr/2")
+ ).
+
+:- pred convert_maybe_pseudo_type_info_or_self_to_elds(module_info::in,
+ rtti_maybe_pseudo_type_info_or_self::in,
+ elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
+
+convert_maybe_pseudo_type_info_or_self_to_elds(MI, TI, Expr, !Defns) :-
+ maybe_pseudo_type_info_or_self_to_elds(MI, TI, RttiId, Defns),
!:Defns = list.sort_and_remove_dups(Defns ++ !.Defns),
-
- Term = elds_tuple([
- elds_term(NameTerm),
- elds_rtti_ref(RttiId)
- ]).
+ Expr = elds_rtti_ref(RttiId).
+
+:- pred convert_maybe_pseudo_type_info_to_elds(module_info::in,
+ rtti_maybe_pseudo_type_info::in,
+ elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
+
+convert_maybe_pseudo_type_info_to_elds(MI, TI, Expr, !Defns) :-
+ maybe_pseudo_type_info_to_elds(MI, TI, RttiId, Defns),
+ !:Defns = list.sort_and_remove_dups(Defns ++ !.Defns),
+ Expr = elds_rtti_ref(RttiId).
:- pred maybe_pseudo_type_info_or_self_to_elds(module_info::in,
rtti_maybe_pseudo_type_info_or_self::in,
@@ -810,59 +848,6 @@
maybe_pseudo_type_info_to_elds(ModuleInfo, pseudo(PTypeInfo), RttiId, Defns) :-
RttiId = elds_rtti_pseudo_type_info_id(PTypeInfo),
rtti_pseudo_type_info_to_elds(ModuleInfo, PTypeInfo, Defns).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- import_module deconstruct.
-:- import_module exception.
-
- %
- % convert_to_elds_term(Term) = ELDSTerm
- %
- % takes a Mercury type which doesn't contain any existential types
- % and generate an elds_term which represents how that term would
- % be represented in Erlang.
- %
- % Note this predicate will throw an exception if the type contains
- % a noncanonical type: see do_not_allow documentation
- % in library/deconstruct.m
- %
- % It also doesn't generate the correct ELDS term for types which
- % contain existentially quantified functors.
- %
-:- func convert_to_elds_term(T) = elds_term.
-
-convert_to_elds_term(Term) = ELDS :-
- ( dynamic_cast(Term, Int) ->
- ELDS = elds_int(Int)
- ; dynamic_cast(Term, Char) ->
- ELDS = elds_char(Char)
- ; dynamic_cast(Term, String) ->
- ELDS = elds_string(String)
- ; dynamic_cast(Term, Float) ->
- ELDS = elds_float(Float)
- ;
- functor(Term, do_not_allow, Functor, Arity),
- SubETerms = list.map(convert_arg_to_elds_term(Term), 0 .. (Arity - 1)),
- Exprs = list.map(func(T) = elds_term(T), SubETerms),
-
- ( Functor = "{}" ->
- ELDS = elds_tuple(Exprs)
- ;
- FunctorTerm = elds_term(elds_atom(unqualified(Functor))),
- ELDS = elds_tuple([FunctorTerm | Exprs])
- )
- ).
-
-:- func convert_arg_to_elds_term(T, int) = elds_term.
-
-convert_arg_to_elds_term(Term, Index) = ELDS :-
- ( arg(Term, do_not_allow, Index, Arg) ->
- ELDS = convert_to_elds_term(Arg)
- ;
- unexpected(this_file, "convert_arg_to_elds_term/2")
- ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.5
diff -u -r1.5 erl_unify_gen.m
--- compiler/erl_unify_gen.m 1 Jun 2007 04:12:50 -0000 1.5
+++ compiler/erl_unify_gen.m 4 Jun 2007 06:40:58 -0000
@@ -12,6 +12,23 @@
% This module is part of the Erlang code generator.
% It handles Erlang code generation for unifications.
%
+% TODO
+% type t
+% ---> f(int, string)
+% ; some [T] f(T).
+%
+% will generate for the first alternative
+% {f, Int, String}
+% and for the second alternative
+% {f, TypeInfo_for_t, T}
+%
+% which means that the RTTI routines will not be able to distinguish
+% between the two alternatives.
+% The suggested fix is to place the arity on all functors for types
+% for which at least one functor is existentially quantified.
+% Once this fix is done, update the comment on
+% erlang_rtti_implementation.matches_du_functor
+%
%-----------------------------------------------------------------------------%
:- module erl_backend.erl_unify_gen.
Index: compiler/erlang_rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/erlang_rtti.m,v
retrieving revision 1.1
diff -u -r1.1 erlang_rtti.m
--- compiler/erlang_rtti.m 1 Jun 2007 02:12:58 -0000 1.1
+++ compiler/erlang_rtti.m 4 Jun 2007 06:40:58 -0000
@@ -18,6 +18,9 @@
% In the context of the MLDS backend erlang_rtti.m is the equivalent of
% rtti.m, while erl_rtti.m is the equivalent to rtti_to_mlds.m
%
+% These types have to be kept in sync with the corresponding types in
+% library/erlang_rtti_implementation.m
+%
%-----------------------------------------------------------------------------%
:- module backend_libs.erlang_rtti.
@@ -102,17 +105,19 @@
edu_name :: string,
edu_orig_arity :: int,
- % Size of the tuple needed to represent the
- % functor.
+ % The declaration order of 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_rep :: erlang_atom_raw,
edu_arg_infos :: list(du_arg_info),
edu_exist_info :: maybe(exist_info)
).
+
+:- type erlang_atom_raw
+ ---> erlang_atom_raw(string).
% The list of type constructors that are used behind the scenes by
% the Mercury implementation.
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/erlang_rtti_implementation.m,v
retrieving revision 1.3
diff -u -r1.3 erlang_rtti_implementation.m
--- library/erlang_rtti_implementation.m 1 Jun 2007 08:30:58 -0000 1.3
+++ library/erlang_rtti_implementation.m 4 Jun 2007 06:40:58 -0000
@@ -285,7 +285,12 @@
Functor, Arity, Arguments) :-
(
TypeCtorRep = etcr_du,
- Functor = "XXX", Arity = 0, Arguments = []
+ FunctorReps = TypeCtorInfo ^ type_ctor_functors,
+ FunctorRep = matching_du_functor(FunctorReps, Term),
+ Functor = FunctorRep ^ edu_name,
+ Arity = FunctorRep ^ edu_orig_arity,
+ Arguments = list.map(
+ get_du_functor_arg(TypeInfo, FunctorRep, Term), 1 .. Arity)
;
TypeCtorRep = etcr_list,
Functor = "XXX", Arity = 0, Arguments = []
@@ -366,8 +371,8 @@
Arity = 0,
Arguments = []
;
- deconstruct_2(Term, TypeInfo, TypeCtorInfo, etcr_foreign, NonCanon,
- Functor, Arity, Arguments)
+ deconstruct_2(Term, TypeInfo, TypeCtorInfo,
+ etcr_foreign, NonCanon, Functor, Arity, Arguments)
)
)
;
@@ -389,6 +394,132 @@
).
%
+ % matching_du_functor(Functors, Term)
+ %
+ % finds the erlang_du_functor in the list Functors which describes
+ % the given Term.
+ %
+:- func matching_du_functor(list(erlang_du_functor), T) = erlang_du_functor.
+
+matching_du_functor([], _) = func_error(this_file ++ " matching_du_functor/2").
+matching_du_functor([F | Fs], T) =
+ ( matches_du_functor(T, F) ->
+ F
+ ;
+ matching_du_functor(Fs, T)
+ ).
+
+ %
+ % A functor matches a term, if the first argument of the term
+ % is the same erlang atom as the recorded in the edu_rep field,
+ % and the size of the term matches the calculated size of term.
+ %
+ % Note we have to do this second step because a functor is distinguished
+ % by both it's name and arity.
+ %
+ % Note it is possible for this code to do the wrong thing, see the comment
+ % at the top of erl_unify_gen.m.
+ %
+:- pred matches_du_functor(T::in, erlang_du_functor::in) is semidet.
+
+matches_du_functor(Term, Functor) :-
+ check_functor(Term, Functor ^ edu_rep, Size),
+ Functor ^ edu_orig_arity + 1 + extra_args(Functor) = Size.
+
+:- pred check_functor(T::in, erlang_atom::in, int::out) is semidet.
+:- pragma foreign_proc("Erlang", check_functor(Term::in, Atom::in, Size::out),
+ [will_not_call_mercury, promise_pure, thread_safe], "
+ Functor = element(1, Term),
+ Size = size(Term),
+ SUCCESS_INDICATOR = Functor =:= Atom
+").
+check_functor(_, _, 0) :-
+ semidet_unimplemented("check_functor/3").
+
+ %
+ % Calculate the number of type_info and type_class_infos which
+ % have been introduced due to existentially quantified type
+ % variables on the given functor.
+ %
+:- func extra_args(erlang_du_functor) = int.
+
+extra_args(Functor) = ExtraArgs :-
+ MaybeExist = Functor ^ edu_exist_info,
+ (
+ MaybeExist = yes(ExistInfo),
+ % XXX we should record the number of typeclass_constraints
+ % in the exist_info
+ ExtraArgs = ExistInfo ^ exist_num_plain_typeinfos +
+ list.length(ExistInfo ^ exist_typeclass_constraints)
+ ;
+ MaybeExist = no,
+ ExtraArgs = 0
+ ).
+
+ %
+ % get_du_functor_arg(TypeInfo, Functor, Term, N)
+ %
+ % returns a univ which represent the N'th argument of the term, Term,
+ % which is described the erlang_du_functor, Functor, and the type_info,
+ % TypeInfo.
+ %
+:- func get_du_functor_arg(type_info, erlang_du_functor, T, int) = univ.
+
+get_du_functor_arg(TypeInfo, Functor, Term, Loc) = Univ :-
+ ArgInfo = list.index1_det(Functor ^ edu_arg_infos, Loc),
+
+ EvalTypeInfo = eval_type_info(ArgInfo ^ du_arg_type),
+ (
+ EvalTypeInfo = type_info(ArgTypeInfo)
+ ;
+ EvalTypeInfo = universal_type_info(N),
+ ArgTypeInfo = TypeInfo ^ type_info_index(N)
+ ;
+ EvalTypeInfo = existential_type_info(N),
+ MaybeExist = Functor ^ edu_exist_info,
+ (
+ MaybeExist = yes(ExistInfo),
+ ExistLocn = list.index1_det(ExistInfo ^ exist_typeinfo_locns, N),
+ (
+ ExistLocn = plain_typeinfo(X),
+
+ % plain_typeinfo index's start at 0, so we need to
+ % add two to get to the first index.
+ ArgTypeInfo = unsafe_cast(get_subterm(TypeInfo, Term, X, 2))
+ ;
+ ExistLocn = typeinfo_in_tci(A, B),
+
+ % A starts at index 0 and measures from the start
+ % of the list of plain type_infos
+ %
+ % B starts at index 1 and measures from the start
+ % of the type_class_info
+ %
+ % Hence the addition of two extra arguments to find the
+ % type_class_info and then the addition of one extra
+ % arg to find the type_info in the type_class_info.
+ %
+ % Note it's safe to pass a bogus type_info to
+ % get_subterm because we never use the returned
+ % type_info.
+ %
+ Bogus = TypeInfo,
+ TypeClassInfo = get_subterm(Bogus, Term, A, 2),
+ ArgTypeInfo = unsafe_cast(
+ get_subterm(Bogus, TypeClassInfo, B, 1))
+ )
+ ;
+ MaybeExist = no,
+ error(this_file ++ " get_du_functor_arg: no exist info")
+ )
+
+ ),
+
+ SubTerm = get_subterm(ArgTypeInfo, Term, Loc, extra_args(Functor) + 1),
+ Univ = univ(SubTerm).
+
+
+ %
% get_tuple_arg(TypeInfo, Tuple, N)
%
% Get the N'th argument as a univ from the tuple
@@ -568,6 +699,18 @@
type_ctor_arity(_) = 0 :-
det_unimplemented("type_ctor_arity").
+:- func type_ctor_functors(type_ctor_info) = list(erlang_du_functor).
+
+:- pragma foreign_proc("Erlang",
+ type_ctor_functors(TypeCtorInfo::in) = (Arity::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Arity = element(tci_functors(), TypeCtorInfo)
+").
+
+type_ctor_functors(_) = [] :-
+ det_unimplemented("type_ctor_functors").
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -584,6 +727,10 @@
[promise_pure],
"
% TypeInfo_for_U to avoid compiler warning
+
+ %io:format(""get_subterm(~p, ~p, ~p, ~p)~n"",
+ % [TypeInfo, Term, Index, ExtraArgs]),
+
TypeInfo_for_T = TypeInfo,
Arg = element(Index + ExtraArgs, Term)
").
@@ -672,7 +819,7 @@
semidet_unimplemented(S) :-
( semidet_succeed ->
- error("rtti_implementation: unimplemented: " ++ S)
+ error(this_file ++ ": unimplemented: " ++ S)
;
semidet_succeed
).
@@ -681,7 +828,7 @@
det_unimplemented(S) :-
( semidet_succeed ->
- error("rtti_implementation: unimplemented: " ++ S)
+ error(this_file ++ ": unimplemented: " ++ S)
;
true
).
@@ -788,6 +935,117 @@
type_to_univ(Term, Univ),
det_univ_to_type(Univ, Actual).
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%
+% These types have to be kept in sync with the corresponding types in
+% compiler/erlang_rtti.m
+%
+
+:- import_module maybe.
+
+:- type erlang_atom.
+:- pragma foreign_type("Erlang", erlang_atom, "").
+:- type erlang_atom ---> erlang_atom.
+
+:- type erlang_du_functor
+ ---> erlang_du_functor(
+ edu_name :: string,
+ edu_orig_arity :: int,
+ edu_ordinal :: int,
+ edu_rep :: erlang_atom,
+ edu_arg_infos :: list(du_arg_info),
+ edu_exist_info :: maybe(exist_info)
+ ).
+
+:- type du_arg_info
+ ---> du_arg_info(
+ du_arg_name :: maybe(string),
+ du_arg_type :: type_info_thunk
+ ).
+
+:- type exist_info
+ ---> exist_info(
+ exist_num_plain_typeinfos :: int,
+ exist_num_typeinfos_in_tcis :: int,
+ exist_typeclass_constraints :: list(tc_constraint),
+ exist_typeinfo_locns :: list(exist_typeinfo_locn)
+ ).
+
+:- type tc_constraint
+ ---> tc_constraint(
+ tcc_class_name :: tc_name,
+ tcc_types :: list(tc_type)
+ ).
+
+:- type exist_typeinfo_locn
+ ---> plain_typeinfo(
+ int % The typeinfo is stored directly in the cell,
+ % at this offset.
+ )
+ ; typeinfo_in_tci(
+ int, % The typeinfo is stored indirectly in the
+ % typeclass info stored at this offset in the cell.
+
+ int % To find the typeinfo inside the typeclass info
+ % structure, give this integer to the
+ % MR_typeclass_info_type_info macro.
+ ).
+
+:- type tc_name
+ ---> tc_name(
+ tcn_module :: module_name,
+ tcn_name :: string,
+ tcn_arity :: int
+ ).
+
+:- type module_name == sym_name.
+
+:- type sym_name
+ ---> unqualified(string)
+ ; qualified(sym_name, string).
+
+:- type tc_type == maybe_pseudo_type_info.
+
+:- type maybe_pseudo_type_info
+ ---> pseudo(pseudo_type_info_thunk)
+ ; plain(type_info_thunk).
+
+% XXX
+:- type pseudo_type_info_thunk.
+:- pragma foreign_type("Erlang", pseudo_type_info_thunk, "").
+:- type pseudo_type_info_thunk ---> pseudo_type_info_thunk.
+
+:- type type_info_thunk.
+:- pragma foreign_type("Erlang", type_info_thunk, "").
+:- type type_info_thunk ---> type_info_thunk.
+
+:- type evaluated_type_info_thunk
+ ---> universal_type_info(int)
+ ; existential_type_info(int)
+ ; type_info(type_info)
+ .
+
+:- func eval_type_info(type_info_thunk) = evaluated_type_info_thunk.
+:- pragma foreign_proc("Erlang", eval_type_info(Thunk::in) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ MaybeTypeInfo = Thunk(),
+ TypeInfo =
+ if
+ is_integer(MaybeTypeInfo), MaybeTypeInfo < 512 ->
+ { universal_type_info, MaybeTypeInfo };
+ is_integer(MaybeTypeInfo) ->
+ { existential_type_info, MaybeTypeInfo - 512 };
+ true ->
+ { type_info, MaybeTypeInfo }
+ end,
+ % io:format(""eval_type_info: ~p~n"", [TypeInfo]),
+ void
+").
+eval_type_info(X) = erlang_rtti_implementation.unsafe_cast(X) :-
+ det_unimplemented("eval_type_info/1").
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- func this_file = string.
--------------------------------------------------------------------------
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