[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