[m-rev.] for review: implement construct on the erlang backend
Peter Ross
pro at missioncriticalit.com
Thu Aug 30 23:49:31 AEST 2007
Hi,
For peter wang to review.
Peter with this patch construct_test passes.
===================================================================
Estimated hours taken: 6
Branches: main
Implement construct on the erlang backend.
library/construct.m:
Call the erlang_rtti_implementation of construct and construct_tuple_2.
Add erlang implementation of null.
library/erlang_rtti_implementation.m:
Implement construct, construct_tuple_2 and compare_type_infos.
library/type_desc.m:
Call compare_type_infos for comparing type_descs.
Add implementation of type_desc_to_pseudo_type_desc.
Index: library/construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.38
diff -u -r1.38 construct.m
--- library/construct.m 30 Aug 2007 05:46:01 -0000 1.38
+++ library/construct.m 30 Aug 2007 13:13:25 -0000
@@ -358,6 +358,14 @@
succeeded = (S == null);
").
+:- pragma foreign_proc("Erlang",
+ null(_S::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ % There are no null pointers in erlang
+ SUCCESS_INDICATOR = false
+").
+
get_functor_ordinal(TypeDesc, FunctorNumber) = Ordinal :-
get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal).
@@ -929,6 +937,9 @@
SUCCESS_INDICATOR = success;
}").
+construct(TypeDesc, Index, Args) =
+ erlang_rtti_implementation.construct(TypeDesc, Index, Args).
+
construct_tuple(Args) =
construct_tuple_2(Args, list.map(univ_type, Args), list.length(Args)).
@@ -982,3 +993,6 @@
*/
MR_new_univ_on_hp(Term, type_info, new_data);
}").
+
+construct_tuple_2(Args, ArgTypes, Arity) =
+ erlang_rtti_implementation.construct_tuple_2(Args, ArgTypes, Arity).
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/erlang_rtti_implementation.m,v
retrieving revision 1.17
diff -u -r1.17 erlang_rtti_implementation.m
--- library/erlang_rtti_implementation.m 30 Aug 2007 05:46:01 -0000 1.17
+++ library/erlang_rtti_implementation.m 30 Aug 2007 13:13:29 -0000
@@ -82,6 +82,11 @@
:- pred get_functor_lex(type_desc.type_desc::in, int::in, int::out)
is semidet.
+:- func construct(type_desc::in, int::in, list(univ)::in) = (univ::out)
+ is semidet.
+
+:- func construct_tuple_2(list(univ), list(type_desc), int) = univ.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -338,9 +343,87 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-compare_type_infos(Res, _, _) :-
- Res = (=),
- det_unimplemented("compare_type_infos/3").
+compare_type_infos(Res, TypeInfoA, TypeInfoB) :-
+ TA = collapse_equivalences(TypeInfoA),
+ TB = collapse_equivalences(TypeInfoB),
+
+ TCA = TA ^ type_ctor_info_evaled,
+ TCB = TB ^ type_ctor_info_evaled,
+
+ compare(NameRes, TCA ^ type_ctor_type_name, TCB ^ type_ctor_type_name),
+ ( NameRes = (=) ->
+ compare(ModuleRes,
+ TCA ^ type_ctor_module_name, TCB ^ type_ctor_module_name),
+ ( ModuleRes = (=) ->
+ (
+ type_ctor_is_variable_arity(TCA)
+ ->
+ ArityA = TA ^ var_arity_type_info_arity,
+ ArityB = TB ^ var_arity_type_info_arity,
+ compare(ArityRes, ArityA, ArityB),
+ ( ArityRes = (=) ->
+ compare_var_arity_typeinfos(1, ArityA, Res, TA, TB)
+ ;
+ Res = ArityRes
+ )
+ ;
+ ArityA = TCA ^ type_ctor_arity,
+ ArityB = TCA ^ type_ctor_arity,
+ compare(ArityRes, ArityA, ArityB),
+ ( ArityRes = (=) ->
+ compare_sub_typeinfos(1, ArityA, Res, TA, TB)
+ ;
+ Res = ArityRes
+ )
+ )
+ ;
+ Res = ModuleRes
+ )
+ ;
+ Res = NameRes
+ ).
+
+:- pred compare_sub_typeinfos(int::in, int::in,
+ comparison_result::out, type_info::in, type_info::in) is det.
+
+compare_sub_typeinfos(Loc, Arity, Result, TypeInfoA, TypeInfoB) :-
+ ( Loc > Arity ->
+ Result = (=)
+ ;
+ SubTypeInfoA = TypeInfoA ^ type_info_index(Loc),
+ SubTypeInfoB = TypeInfoB ^ type_info_index(Loc),
+
+ compare_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
+ ( SubResult = (=) ->
+ compare_var_arity_typeinfos(Loc + 1, Arity, Result,
+ TypeInfoA, TypeInfoB)
+ ;
+ Result = SubResult
+ )
+ ).
+
+:- pred compare_var_arity_typeinfos(int::in, int::in,
+ comparison_result::out, type_info::in, type_info::in) is det.
+
+compare_var_arity_typeinfos(Loc, Arity, Result, TypeInfoA, TypeInfoB) :-
+ ( Loc > Arity ->
+ Result = (=)
+ ;
+ SubTypeInfoA = TypeInfoA ^ var_arity_type_info_index(Loc),
+ SubTypeInfoB = TypeInfoB ^ var_arity_type_info_index(Loc),
+
+ compare_type_infos(SubResult, SubTypeInfoA, SubTypeInfoB),
+ ( SubResult = (=) ->
+ compare_var_arity_typeinfos(Loc + 1, Arity, Result,
+ TypeInfoA, TypeInfoB)
+ ;
+ Result = SubResult
+ )
+ ).
+
+
+
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1170,6 +1253,184 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+construct(TypeDesc, Index, Args) = Term :-
+ TypeInfo = collapse_equivalences(unsafe_cast(TypeDesc)),
+ TypeCtorInfo = TypeInfo ^ type_ctor_info_evaled,
+ TypeCtorRep = TypeCtorInfo ^ type_ctor_rep,
+
+ (
+ TypeCtorRep = etcr_du,
+ Result = get_functor_with_names(TypeInfo, Index),
+ Result = yes({FunctorName, _FunctorArity, ArgTypes, _ArgNames}),
+ check_arg_types(Args, ArgTypes),
+ Term = construct_univ(TypeInfo, FunctorName, Args)
+ ;
+ TypeCtorRep = etcr_dummy,
+ Term = construct_univ(TypeInfo, "false", [])
+ ;
+ TypeCtorRep = etcr_list,
+ ( Index = 1, Args = [Head, Tail] ->
+ compare_type_infos((=),
+ univ_type_info(Head), TypeInfo ^ type_info_index(1)),
+ compare_type_infos((=), univ_type_info(Tail), TypeInfo),
+ Term = construct_list_cons_univ(TypeInfo, Head, Tail)
+ ;
+ Index = 0,
+ Args = [],
+ Term = construct_empty_list_univ(TypeInfo)
+ )
+ ;
+ TypeCtorRep = etcr_tuple,
+ Arity = TypeInfo ^ var_arity_type_info_arity,
+ check_tuple_arg_types(TypeInfo, 1 .. Arity, Args),
+ Term = construct_tuple_univ(TypeInfo, Args)
+ ;
+ ( TypeCtorRep = etcr_array
+ ; TypeCtorRep = etcr_eqv
+ ; TypeCtorRep = etcr_int
+ ; TypeCtorRep = etcr_float
+ ; TypeCtorRep = etcr_char
+ ; TypeCtorRep = etcr_string
+ ; TypeCtorRep = etcr_void
+ ; TypeCtorRep = etcr_stable_c_pointer
+ ; TypeCtorRep = etcr_c_pointer
+ ; TypeCtorRep = etcr_pred
+ ; TypeCtorRep = etcr_func
+ ; TypeCtorRep = etcr_ref
+ ; TypeCtorRep = etcr_type_desc
+ ; TypeCtorRep = etcr_pseudo_type_desc
+ ; TypeCtorRep = etcr_type_ctor_desc
+ ; TypeCtorRep = etcr_type_info
+ ; TypeCtorRep = etcr_type_ctor_info
+ ; TypeCtorRep = etcr_typeclass_info
+ ; TypeCtorRep = etcr_base_typeclass_info
+ ; TypeCtorRep = etcr_foreign
+ ; TypeCtorRep = etcr_hp
+ ; TypeCtorRep = etcr_subgoal
+ ; TypeCtorRep = etcr_ticket
+ ),
+ error("construct: unable to construct something of type " ++
+ string(TypeCtorRep))
+ ).
+
+:- pred check_arg_types(list(univ)::in, list(type_info)::in) is semidet.
+
+check_arg_types([], []).
+check_arg_types([U | Us], [TI | TIs]) :-
+ compare_type_infos((=), univ_type_info(U), TI),
+ check_arg_types(Us, TIs).
+
+:- pred check_tuple_arg_types(type_info::in,
+ list(int)::in, list(univ)::in) is semidet.
+
+check_tuple_arg_types(_, [], []).
+check_tuple_arg_types(TypeInfo, [I | Is], [U | Us]) :-
+ compare_type_infos((=),
+ TypeInfo ^ var_arity_type_info_index(I), univ_type_info(U)),
+ check_tuple_arg_types(TypeInfo, Is, Us).
+
+:- func univ_type_info(univ) = type_info.
+
+:- pragma foreign_proc(erlang,
+ univ_type_info(Univ::in) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ {univ_cons, TypeInfo, _} = Univ
+").
+
+
+ %
+ % Construct a du type and store it in a univ.
+ %
+:- func construct_univ(type_info, string, list(univ)) = univ.
+
+:- pragma foreign_proc(erlang,
+ construct_univ(TypeInfo::in, Functor::in, Args::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ if
+ is_binary(Functor) ->
+ List = binary_to_list(Functor);
+ true ->
+ List = Functor
+ end,
+ Univ = {univ_cons, TypeInfo, list_to_tuple(
+ [list_to_atom(List) | lists:map(fun univ_to_value/1, Args)])}
+").
+
+ %
+ % Construct a tuple and store it in a univ.
+ %
+:- func construct_tuple_univ(type_info, list(univ)) = univ.
+
+:- pragma foreign_proc(erlang,
+ construct_tuple_univ(TypeInfo::in, Args::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ Univ = {univ_cons, TypeInfo,
+ list_to_tuple(lists:map(fun univ_to_value/1, Args))}
+").
+
+ %
+ % Construct a empty list and store it in a univ.
+ %
+:- func construct_empty_list_univ(type_info) = univ.
+
+:- pragma foreign_proc(erlang,
+ construct_empty_list_univ(TypeInfo::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ Univ = {univ_cons, TypeInfo, []}
+").
+
+ %
+ % Construct a cons cell and store it in a univ.
+ %
+:- func construct_list_cons_univ(type_info, univ, univ) = univ.
+
+:- pragma foreign_proc(erlang,
+ construct_list_cons_univ(TypeInfo::in, H::in, T::in) = (Univ::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+ Univ = {univ_cons, TypeInfo, [univ_to_value(H) | univ_to_value(T)]}
+").
+
+:- pragma foreign_code(erlang, "
+ %
+ % Get the value out of the univ
+ % Note we assume that we've checked that the value is consistent
+ % with another type_info elsewhere,
+ % for example in check_arg_types and check_tuple_arg_types
+ %
+univ_to_value(Univ) ->
+ {univ_cons, _UnivTypeInfo, Value} = Univ,
+ Value.
+
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+construct_tuple_2(Args, ArgTypes, Arity) = Tuple :-
+ TypeInfo = unsafe_cast(type_of(_ : {})),
+ Tuple = construct_tuple_3(TypeInfo, Arity, ArgTypes, Args).
+
+:- func construct_tuple_3(type_info, int, list(type_desc), list(univ)) = univ.
+
+:- pragma foreign_proc(erlang,
+ construct_tuple_3(TI::in,
+ Arity::in, ArgTypes::in, Args::in) = (Term::out),
+ [will_not_call_mercury, thread_safe, promise_pure], "
+
+ % Get the type_ctor_info from the empty tuple type_info
+ % and use that to create the correct var_arity type_info
+ TCI = element(?ML_ti_type_ctor_info, TI),
+ TupleTypeInfo = list_to_tuple([TCI, Arity | ArgTypes]),
+
+ Tuple = list_to_tuple(lists:map(fun univ_to_value/1, Args)),
+
+ Term = {univ_cons, TupleTypeInfo, Tuple}
+").
+
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- pragma foreign_decl("Erlang", "
% These are macros for efficiency.
Index: library/type_desc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/type_desc.m,v
retrieving revision 1.52
diff -u -r1.52 type_desc.m
--- library/type_desc.m 30 Aug 2007 05:46:02 -0000 1.52
+++ library/type_desc.m 30 Aug 2007 13:14:04 -0000
@@ -372,6 +372,13 @@
PseudoTypeDesc = TypeDesc;
").
+:- pragma foreign_proc("Erlang",
+ type_desc_to_pseudo_type_desc(TypeDesc::in) = (PseudoTypeDesc::out),
+ [will_not_call_mercury, thread_safe, promise_pure, will_not_modify_trail],
+"
+ PseudoTypeDesc = TypeDesc
+").
+
type_desc_to_pseudo_type_desc(_TypeDesc) = _PseudoTypeDesc :-
% The backends in which we use this definition of this predicate
% don't yet support pseudo_type_descs.
@@ -894,11 +901,10 @@
:- pragma foreign_code("Erlang", "
'__Unify____type_desc_0_0'(X0, Y0) ->
- X = eval_if_function(X0),
- Y = eval_if_function(Y0),
- case X =:= Y of
- true -> {};
- false -> fail
+ Res = mercury__erlang_rtti_implementation:compare_type_infos_3_p_0(X0, Y0),
+ case Res of
+ { '=' } -> {};
+ _ -> fail
end.
'__Unify____type_ctor_desc_0_0'(X0, Y0) ->
@@ -913,13 +919,7 @@
throw(""foreign code for unifying pseudo_type_desc"").
'__Compare____type_desc_0_0'(X0, Y0) ->
- X = eval_if_function(X0),
- Y = eval_if_function(Y0),
- if
- X =:= Y -> {'='};
- X < Y -> {'<'};
- true -> {'>'}
- end.
+ mercury__erlang_rtti_implementation:compare_type_infos_3_p_0(X0, Y0).
'__Compare____type_ctor_desc_0_0'(X0, Y0) ->
X = eval_if_function(X0),
--------------------------------------------------------------------------
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