[m-rev.] diff: generate simpler unify/compare preds for erlang

[Peter Wang]

Estimated hours taken: 3
Branches: main

compiler/erl_code_gen.m:
	When possible, ignore the compiler generated unify/compare predicates
	and directly output simpler code that compares high level data
	structures with Erlang =:=  and < operators.  This is similar a
	previous change, but in that change we were changing the call sites.

compiler/type_util.m:
	Fix type_definitely_has_no_user_defined_equality_pred.  It was
	incorrectly succeeding for d.u. types which have data constructors with
	arguments of types that have user-defined equality predicates.


Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.16
diff -u -r1.16 erl_code_gen.m
--- compiler/erl_code_gen.m	2 Jul 2007 05:49:32 -0000	1.16
+++ compiler/erl_code_gen.m	3 Jul 2007 03:02:46 -0000
@@ -63,6 +63,7 @@
 :- import_module libs.compiler_util.
 :- import_module libs.globals.
 :- import_module libs.options.
+:- import_module mdbcomp.prim_data.
 :- import_module parse_tree.prog_data.
 :- import_module parse_tree.prog_foreign.
 :- import_module parse_tree.prog_type.
@@ -189,10 +190,122 @@
 erl_gen_procs([ProcId | ProcIds], ModuleInfo, PredId, PredInfo, ProcTable,
         !Defns) :-
     map.lookup(ProcTable, ProcId, ProcInfo),
-    erl_gen_proc(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo, !Defns),
+    (
+        erl_maybe_gen_simple_special_pred(ModuleInfo, PredId, ProcId,
+            PredInfo, ProcInfo, !Defns)
+    ->
+        true
+    ;
+        erl_gen_proc(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo, !Defns)
+    ),
     erl_gen_procs(ProcIds, ModuleInfo, PredId, PredInfo, ProcTable, !Defns).
 
 %-----------------------------------------------------------------------------%
+
+    % erl_maybe_gen_simple_special_pred(ModuleInfo, PredId, ProcId,
+    %   PredInfo, ProcInfo, !Defns)
+    %
+    % If the procedure is a compiler generated unification or comparison
+    % procedure, and the arguments are ground, and the values of the types they
+    % are comparing do not have user-defined equality or comparison then
+    % generate simpler versions of those procedures using the Erlang comparison
+    % operators.  Otherwise fail.
+    %
+:- pred erl_maybe_gen_simple_special_pred(module_info::in,
+    pred_id::in, proc_id::in, pred_info::in, proc_info::in,
+    list(elds_defn)::in, list(elds_defn)::out) is semidet.
+
+erl_maybe_gen_simple_special_pred(ModuleInfo, PredId, ProcId,
+        PredInfo, ProcInfo, !Defns) :-
+    PredName = pred_info_name(PredInfo),
+    PredArity = pred_info_orig_arity(PredInfo),
+    special_pred_name_arity(SpecialId, _, PredName, PredArity),
+    proc_info_get_headvars(ProcInfo, Args),
+    proc_info_get_vartypes(ProcInfo, VarTypes),
+    (
+        SpecialId = spec_pred_unify,
+        in_in_unification_proc_id(ProcId),
+        list.reverse(Args, [Y, X | _]),
+        map.lookup(VarTypes, Y, Type),
+        type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type),
+        erl_gen_simple_in_in_unification(ModuleInfo, PredId, ProcId, X, Y,
+            ProcDefn)
+    ;
+        SpecialId = spec_pred_compare,
+        list.reverse(Args, [Y, X, _Res | _]),
+        map.lookup(VarTypes, Y, Type),
+        type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type),
+        erl_gen_simple_compare(ModuleInfo, PredId, ProcId, X, Y, ProcDefn)
+    ),
+    !:Defns = [ProcDefn | !.Defns].
+
+:- pred erl_gen_simple_in_in_unification(module_info::in,
+    pred_id::in, proc_id::in, prog_var::in, prog_var::in, elds_defn::out)
+    is det.
+
+erl_gen_simple_in_in_unification(ModuleInfo, PredId, ProcId, X, Y, ProcDefn) :-
+    Info = erl_gen_info_init(ModuleInfo, PredId, ProcId),
+    erl_gen_info_get_input_vars(Info, InputVars),
+
+    %   '__Unify__'(X, Y) ->
+    %       case X =:= Y of
+    %           true -> {};
+    %           false -> fail
+    %       end.
+
+    Clause = elds_clause(terms_from_vars(InputVars), ClauseExpr),
+    ClauseExpr = elds_case_expr(CompareXY, [TrueCase, FalseCase]),
+    CompareXY = elds_binop((=:=), expr_from_var(X), expr_from_var(Y)),
+    TrueCase = elds_case(elds_true, elds_term(elds_empty_tuple)),
+    FalseCase = elds_case(elds_false, elds_term(elds_fail)),
+
+    erl_gen_info_get_varset(Info, ProcVarSet),
+    erl_gen_info_get_env_vars(Info, EnvVarNames),
+    ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet,
+        body_defined_here(Clause), EnvVarNames).
+
+:- pred erl_gen_simple_compare(module_info::in, pred_id::in, proc_id::in,
+    prog_var::in, prog_var::in, elds_defn::out) is det.
+
+erl_gen_simple_compare(ModuleInfo, PredId, ProcId, X, Y, ProcDefn) :-
+    Info = erl_gen_info_init(ModuleInfo, PredId, ProcId),
+    erl_gen_info_get_input_vars(Info, InputVars),
+
+    XExpr = expr_from_var(X),
+    YExpr = expr_from_var(Y),
+
+    %   '__Compare__'(X, Y) ->
+    %       case X =:= Y of
+    %           true -> {{'='}};
+    %           false ->
+    %               case X < Y of
+    %                   true -> {{'<'}};
+    %                   false -> {{'>'}};
+    %               end
+    %       end.
+    %
+    Clause = elds_clause(terms_from_vars(InputVars), ClauseExpr),
+    ClauseExpr = elds_case_expr(CondEq, [IsEq, IsNotEq]),
+
+    CondEq = elds_binop((=:=), XExpr, YExpr),
+    IsEq = elds_case(elds_true, enum_in_tuple("=")),
+    IsNotEq = elds_case(elds_false, elds_case_expr(CondLt, [IsLt, IsGt])),
+
+    CondLt = elds_binop((<), XExpr, YExpr),
+    IsLt = elds_case(elds_true, enum_in_tuple("<")),
+    IsGt = elds_case(elds_false, enum_in_tuple(">")),
+
+    erl_gen_info_get_varset(Info, ProcVarSet),
+    erl_gen_info_get_env_vars(Info, EnvVarNames),
+    ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet,
+        body_defined_here(Clause), EnvVarNames).
+
+:- func enum_in_tuple(string) = elds_expr.
+
+enum_in_tuple(X) = 
+    elds_term(elds_tuple([elds_term(make_enum_alternative(X))])).
+
+%-----------------------------------------------------------------------------%
 %
 % Code for handling individual procedures
 %
@@ -202,9 +315,9 @@
 :- pred erl_gen_proc(module_info::in, pred_id::in, proc_id::in, pred_info::in,
     proc_info::in, list(elds_defn)::in, list(elds_defn)::out) is det.
 
-erl_gen_proc(ModuleInfo, PredId, ProcId, _PredInfo, _ProcInfo, !Defns) :-
-    erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcBody,
-        EnvVarNames),
+erl_gen_proc(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo, !Defns) :-
+    erl_gen_proc_defn(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo,
+        ProcVarSet, ProcBody, EnvVarNames),
     ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet, ProcBody,
         EnvVarNames),
     !:Defns = [ProcDefn | !.Defns].
@@ -212,11 +325,11 @@
     % Generate an ELDS definition for the specified procedure.
     %
 :- pred erl_gen_proc_defn(module_info::in, pred_id::in, proc_id::in,
-    prog_varset::out, elds_body::out, set(string)::out) is det.
+    pred_info::in, proc_info::in, prog_varset::out, elds_body::out,
+    set(string)::out) is det.
 
-erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcBody,
-        EnvVarNames) :-
-    module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
+erl_gen_proc_defn(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo,
+        ProcVarSet, ProcBody, EnvVarNames) :-
     pred_info_get_import_status(PredInfo, ImportStatus),
     proc_info_interface_code_model(ProcInfo, CodeModel),
     proc_info_get_headvars(ProcInfo, HeadVars),

Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.177
diff -u -r1.177 type_util.m
--- compiler/type_util.m	2 Jul 2007 05:30:30 -0000	1.177
+++ compiler/type_util.m	3 Jul 2007 03:02:47 -0000
@@ -73,9 +73,8 @@
 :- pred type_body_has_user_defined_equality_pred(module_info::in,
     hlds_type_body::in, unify_compare::out) is semidet.
 
-    % Succeed iff the principal type constructor of the specified type and none
-    % of its arguments are known not to have user-defined equality or
-    % comparison predicates.
+    % Succeed iff the type (not just the principal type constructor) is known
+    % to not have user-defined equality or comparison predicates.
     %
     % If the type is a type variable, or is abstract, etc.  make the
     % conservative approximation and fail.
@@ -323,6 +322,7 @@
 :- import_module char.
 :- import_module int.
 :- import_module map.
+:- import_module set.
 :- import_module term.
 
 %-----------------------------------------------------------------------------%
@@ -397,20 +397,36 @@
     ).
 
 type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type) :-
-    type_to_type_defn_body(ModuleInfo, Type, TypeBody),
-    type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo,
-        TypeBody),
-    type_to_ctor_and_args_det(Type, _, Args),
-    all [Arg] (
-        list.member(Arg, Args)
-    =>
-        type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Arg)
+    type_definitely_has_no_user_defined_equality_pred_2(ModuleInfo,
+        set.init, Type).
+
+:- pred type_definitely_has_no_user_defined_equality_pred_2(module_info::in,
+    set(mer_type)::in, mer_type::in) is semidet.
+
+type_definitely_has_no_user_defined_equality_pred_2(ModuleInfo,
+        SeenTypes0, Type) :-
+    (if set.contains(SeenTypes0, Type) then
+        % Don't loop on recursive types.
+        true
+    else
+        set.insert(SeenTypes0, Type, SeenTypes),
+        type_to_type_defn_body(ModuleInfo, Type, TypeBody),
+        type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo,
+            SeenTypes, TypeBody),
+        type_to_ctor_and_args_det(Type, _, Args),
+        all [Arg] (
+            list.member(Arg, Args)
+        =>
+            type_definitely_has_no_user_defined_equality_pred_2(ModuleInfo,
+                SeenTypes, Arg)
+        )
     ).
 
 :- pred type_body_definitely_has_no_user_defined_equality_pred(module_info::in,
-    hlds_type_body::in) is semidet.
+    set(mer_type)::in, hlds_type_body::in) is semidet.
 
-type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, TypeBody) :-
+type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, SeenTypes,
+        TypeBody) :-
     module_info_get_globals(ModuleInfo, Globals),
     globals.get_target(Globals, Target),
     (
@@ -423,12 +439,21 @@
                 ForeignTypeBody, _)
         ;
             TypeBody ^ du_type_usereq = no,
-            % There must not be any existentially quantified type variables.
             all [Ctor] (
                 list.member(Ctor, Ctors)
-            =>
-                Ctor = ctor([], _, _, _, _)
-            )
+            => (
+                % There must not be any existentially quantified type
+                % variables.
+                Ctor = ctor([], _, _, Args, _),
+                % The data constructor argument types must not have
+                % user-defined equality preds.
+                all [Arg] (
+                    list.member(ctor_arg(_, ArgType, _), Args)
+                =>
+                    type_definitely_has_no_user_defined_equality_pred_2(
+                        ModuleInfo, SeenTypes, ArgType)
+                )
+            ))
         )
     ;
         TypeBody = hlds_eqv_type(EqvType),
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------