Optimize forwarding in eq and ord plugins

src/api/ppx_deriving.cppo.ml

@@ -319,9 +319,15 @@ let create_quoter () = { next_id = 0; bindings = [] }
 let quote ~quoter expr =
   let loc = !Ast_helper.default_loc in
   let name = "__" ^ string_of_int quoter.next_id in
-  quoter.bindings <- (Vb.mk (pvar name) [%expr fun () -> [%e expr]]) :: quoter.bindings;
+  let (binding_body, quoted_expr) = match expr with
+    | { pexp_desc = Pexp_ident _; _ } ->
+      (expr, evar name)
+    | _ ->
+      ([%expr fun () -> [%e expr]], [%expr [%e evar name] ()])
+  in
+  quoter.bindings <- (Vb.mk (pvar name) binding_body) :: quoter.bindings;
   quoter.next_id <- quoter.next_id + 1;
-  [%expr [%e evar name] ()]
+  quoted_expr
 
 let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr =
   let body =

src_plugins/eq/ppx_deriving_eq.cppo.ml

@@ -66,7 +66,7 @@ and expr_of_typ quoter typ =
   let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   let expr_of_typ = expr_of_typ quoter in
   match attr_equal typ.ptyp_attributes with
-  | Some fn -> Ppx_deriving.quote ~quoter fn
+  | Some fn -> Ppx_deriving.quote ~quoter fn (* eta-expanded if outermost *)
   | None ->
     match typ with
     | [%type: _] -> [%expr fun _ _ -> true]
@@ -112,9 +112,7 @@ and expr_of_typ quoter typ =
         [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y]
       | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
         let equal_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "equal") lid)) in
-        let fwd = app (Ppx_deriving.quote ~quoter equal_fn) (List.map expr_of_typ args) in
-        (* eta-expansion is necessary for recursive groups *)
-        [%expr fun x -> [%e fwd] x]
+        app (Ppx_deriving.quote ~quoter equal_fn) (List.map expr_of_typ args) (* eta-expanded if outermost *)
       | _ -> assert false
       end
     | { ptyp_desc = Ptyp_tuple typs } ->
@@ -189,14 +187,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       raise_errorf ~loc "%s cannot be derived for open types" deriver
   in
   let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
+  let eta_expand expr = match expr with
+    | { pexp_desc = Pexp_fun _; _ } -> expr
+    | _ -> [%expr fun x -> [%e expr] x] (* eta-expansion is necessary for recursive groups *)
+  in
   let out_type =
     Ppx_deriving.strong_type_of_type @@
       core_type_of_decl  ~options ~path type_decl in
   let eq_var =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in
   [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
          (Pat.constraint_ eq_var out_type)
-         (Ppx_deriving.sanitize ~quoter (polymorphize comparator))]
+         (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))]
 
 let () =
   Ppx_deriving.(register (create deriver

src_plugins/ord/ppx_deriving_ord.cppo.ml

@@ -67,7 +67,7 @@ and expr_of_typ quoter typ =
   let loc = typ.ptyp_loc in
   let expr_of_typ = expr_of_typ quoter in
   match attr_compare typ.ptyp_attributes with
-  | Some fn -> Ppx_deriving.quote ~quoter fn
+  | Some fn -> Ppx_deriving.quote ~quoter fn (* eta-expanded if outermost *)
   | None ->
     let typ = Ppx_deriving.remove_pervasives ~deriver typ in
     match typ with
@@ -125,9 +125,7 @@ and expr_of_typ quoter typ =
         [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y]
       | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
         let compare_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "compare") lid)) in
-        let fwd = app (Ppx_deriving.quote ~quoter compare_fn) (List.map expr_of_typ args) in
-        (* eta-expansion is necessary for recursive groups *)
-        [%expr fun x -> [%e fwd] x]
+        app (Ppx_deriving.quote ~quoter compare_fn) (List.map expr_of_typ args) (* eta-expanded if outermost *)
       | _ -> assert false
       end
     | { ptyp_desc = Ptyp_tuple typs } ->
@@ -225,14 +223,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       raise_errorf ~loc "%s cannot be derived for open types" deriver
   in
   let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
+  let eta_expand expr = match expr with
+    | { pexp_desc = Pexp_fun _; _ } -> expr
+    | _ -> [%expr fun x -> [%e expr] x] (* eta-expansion is necessary for recursive groups *)
+  in
   let out_type =
     Ppx_deriving.strong_type_of_type @@
       core_type_of_decl ~options ~path type_decl in
   let out_var =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in
   [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
          (Pat.constraint_ out_var out_type)
-         (Ppx_deriving.sanitize ~quoter (polymorphize comparator))]
+         (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))]
 
 let () =
   Ppx_deriving.(register (create deriver

src_test/eq/test_deriving_eq.cppo.ml

@@ -124,6 +124,10 @@ let test_poly_app ctxt =
   assert_equal ~printer true (equal_poly_app 1.0 1.0);
   assert_equal ~printer false (equal_poly_app 1.0 2.0)
 
+type poly_app_custom = float poly_abs_custom [@equal equal_poly_abs_custom (=)]
+and 'a poly_abs_custom = 'a
+[@@deriving eq]
+
 module List = struct
   type 'a t = [`Cons of 'a | `Nil]
   [@@deriving eq]

src_test/ord/test_deriving_ord.cppo.ml

@@ -151,6 +151,10 @@ let test_poly_app ctxt =
   assert_equal ~printer 0 (compare_poly_app 1.0 1.0);
   assert_equal ~printer (-1) (compare_poly_app 1.0 2.0)
 
+type poly_app_custom = float poly_abs_custom [@compare compare_poly_abs_custom Stdlib.compare]
+and 'a poly_abs_custom = 'a
+[@@deriving ord]
+
 module List = struct
   type 'a t = [`Cons of 'a | `Nil]
   [@@deriving ord]