done implement unified_ops translation

Author: cometkim

compiler/core/lam_convert.ml

@@ -232,7 +232,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Pduprecord -> prim ~primitive:Pduprecord ~args loc
   | Plazyforce -> prim ~primitive:Plazyforce ~args loc
   | Praise _ -> prim ~primitive:Praise ~args loc
-  | Pinfix _ -> assert false
   | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc
   | Pobjorder -> prim ~primitive:Pobjorder ~args loc
   | Pobjmin -> prim ~primitive:Pobjmin ~args loc
@@ -476,16 +475,6 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
     | Lprim (Pimport, args, loc) ->
       let args = Ext_list.map args (convert_aux ~dynamic_import:true) in
       lam_prim ~primitive:Pimport ~args loc
-    | Lprim (Pinfix (Inf_custom (mod_, op)), args, loc) ->
-      let fn = Lam.var (Ident.create_persistent op) in
-      let args = Ext_list.map args (convert_aux ~dynamic_import) in
-      let ap_info : Lam.ap_info =
-        {ap_loc = loc; ap_status = App_na; ap_inlined = Lambda.Default_inline}
-      in
-      Lam.apply fn args ap_info
-    | Lprim (Pinfix Inf_invariant, args, loc) ->
-      (* TODO : invariant *)
-      assert false
     | Lprim (primitive, args, loc) ->
       let args = Ext_list.map args (convert_aux ~dynamic_import) in
       lam_prim ~primitive ~args loc

compiler/ml/lambda.ml

@@ -175,8 +175,6 @@ type immediate_or_pointer = Immediate | Pointer
 
 type is_safe = Safe | Unsafe
 
-type infix_info = Inf_custom of string * string | Inf_invariant
-
 type primitive =
   | Pidentity
   | Pignore
@@ -200,8 +198,6 @@ type primitive =
   | Pccall of Primitive.description
   (* Exceptions *)
   | Praise of raise_kind
-  (* Infix *)
-  | Pinfix of infix_info
   (* object operations *)
   | Pobjcomp of comparison
   | Pobjorder

compiler/ml/lambda.mli

@@ -138,8 +138,6 @@ type pointer_info =
   | Pt_shape_none
   | Pt_assertfalse
 
-type infix_info = Inf_custom of string * string | Inf_invariant
-
 type primitive =
   | Pidentity
   | Pignore
@@ -163,8 +161,6 @@ type primitive =
   | Pccall of Primitive.description
   (* Exceptions *)
   | Praise of raise_kind
-  (* Infix *)
-  | Pinfix of infix_info
   (* object primitives *)
   | Pobjcomp of comparison
   | Pobjorder

compiler/ml/printlambda.ml

@@ -125,8 +125,6 @@ let primitive ppf = function
   | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
-  | Pinfix (Inf_custom (mod_, op)) -> fprintf ppf "%s.%s" mod_ op
-  | Pinfix Inf_invariant -> fprintf ppf "invariant"
   | Pobjcomp Ceq -> fprintf ppf "=="
   | Pobjcomp Cneq -> fprintf ppf "!="
   | Pobjcomp Clt -> fprintf ppf "<"

compiler/ml/translcore.ml

@@ -49,14 +49,30 @@ let transl_extension_constructor env path ext =
 
 (* Translation of primitives *)
 
-(*
-type sargs = (Asttypes.arg_label * Parsetree.expression) list
-
-let translate_unified_application (env : Env.t) (prim : Primitive.description)
-    (sargs : sargs) : Lambda.primitive option =
-  (* TODO *)
-  None
-*)
+let translate_unified_ops (prim : Primitive.description) (env : Env.t)
+    (lhs_type : type_expr) : Lambda.primitive option =
+  (* lhs_type is already unified in type-level *)
+  let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in
+  match entry with
+  | Some {specialization} -> (
+    match specialization with
+    | {int}
+      when is_base_type env lhs_type Predef.path_int
+           || is_base_type env lhs_type Predef.path_char
+           || maybe_pointer_type env lhs_type = Immediate ->
+      Some int
+    | {float = Some float} when is_base_type env lhs_type Predef.path_float ->
+      Some float
+    | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint
+      ->
+      Some bigint
+    | {string = Some string} when is_base_type env lhs_type Predef.path_string
+      ->
+      Some string
+    | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool ->
+      Some bool
+    | {int} -> Some int)
+  | _ -> None
 
 type specialized = {
   objcomp: Lambda.primitive;
@@ -403,12 +419,21 @@ let specialize_comparison
    raise Not_found if primitive is unknown *)
 
 let specialize_primitive p env ty (* ~has_constant_constructor *) =
-  try
-    let table = Hashtbl.find comparisons_table p.prim_name in
-    match is_function_type env ty with
-    | Some (lhs, _rhs) -> specialize_comparison table env lhs
-    | None -> table.objcomp
-  with Not_found -> find_primitive p.prim_name
+  let fn_expr = is_function_type env ty in
+  let unified =
+    match fn_expr with
+    | Some (lhs, _) -> translate_unified_ops p env lhs
+    | None -> None
+  in
+  match unified with
+  | Some primitive -> primitive
+  | None -> (
+    try
+      let table = Hashtbl.find comparisons_table p.prim_name in
+      match fn_expr with
+      | Some (lhs, _rhs) -> specialize_comparison table env lhs
+      | None -> table.objcomp
+    with Not_found -> find_primitive p.prim_name)
 
 (* Eta-expand a primitive *)
 
@@ -467,32 +492,44 @@ let transl_primitive loc p env ty =
 
 let transl_primitive_application loc prim env ty args =
   let prim_name = prim.prim_name in
-  try
+  let unified =
     match args with
-    | [arg1; _]
-      when is_base_type env arg1.exp_type Predef.path_bool
-           && Hashtbl.mem comparisons_table prim_name ->
-      (Hashtbl.find comparisons_table prim_name).boolcomp
-    | _ ->
-      let has_constant_constructor =
-        match args with
-        | [_; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}]
-        | [{exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _]
-        | [_; {exp_desc = Texp_variant (_, None)}]
-        | [{exp_desc = Texp_variant (_, None)}; _] ->
-          true
-        | _ -> false
-      in
-      if has_constant_constructor then
-        match Hashtbl.find_opt comparisons_table prim_name with
-        | Some table when table.simplify_constant_constructor -> table.intcomp
-        | Some _ | None -> specialize_primitive prim env ty
-        (* ~has_constant_constructor*)
-      else specialize_primitive prim env ty
-  with Not_found ->
-    if String.length prim_name > 0 && prim_name.[0] = '%' then
-      raise (Error (loc, Unknown_builtin_primitive prim_name));
-    Pccall prim
+    | [arg1] | [arg1; _] -> translate_unified_ops prim env arg1.exp_type
+    | _ -> None
+  in
+  match unified with
+  | Some primitive -> primitive
+  | None -> (
+    try
+      match args with
+      | [arg1; _]
+        when is_base_type env arg1.exp_type Predef.path_bool
+             && Hashtbl.mem comparisons_table prim_name ->
+        (Hashtbl.find comparisons_table prim_name).boolcomp
+      | _ ->
+        let has_constant_constructor =
+          match args with
+          | [
+              _; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)};
+            ]
+          | [
+              {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _;
+            ]
+          | [_; {exp_desc = Texp_variant (_, None)}]
+          | [{exp_desc = Texp_variant (_, None)}; _] ->
+            true
+          | _ -> false
+        in
+        if has_constant_constructor then
+          match Hashtbl.find_opt comparisons_table prim_name with
+          | Some table when table.simplify_constant_constructor -> table.intcomp
+          | Some _ | None -> specialize_primitive prim env ty
+          (* ~has_constant_constructor*)
+        else specialize_primitive prim env ty
+    with Not_found ->
+      if String.length prim_name > 0 && prim_name.[0] = '%' then
+        raise (Error (loc, Unknown_builtin_primitive prim_name));
+      Pccall prim)
 
 (* To propagate structured constants *)
 

compiler/ml/typecore.ml

@@ -2458,7 +2458,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     in
     let type_clash_context = type_clash_context_from_function sexp sfunct in
     let args, ty_res, fully_applied =
-      match translate_unified_application env funct sargs with
+      match translate_unified_ops env funct sargs with
       | Some (targs, result_type) -> (targs, result_type, true)
       | None -> type_application ?type_clash_context uncurried env funct sargs
     in
@@ -3563,7 +3563,7 @@ and is_automatic_curried_application env funct =
   | Tarrow _ -> true
   | _ -> false
 
-and translate_unified_application (env : Env.t) (funct : Typedtree.expression)
+and translate_unified_ops (env : Env.t) (funct : Typedtree.expression)
     (sargs : sargs) : (targs * Types.type_expr) option =
   match funct.exp_desc with
   | Texp_ident (path, _, _) -> (

compiler/ml/unified_ops.ml

@@ -24,6 +24,14 @@ open Misc
 
   Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts.
   So falling back to int type is the simplest behavior that ensures backwards compatibility.
+
+  Actual implementations of translation are colocated into core modules
+
+  You can find it in:
+  - Type-level : ml/typecore.ml
+  - IR-level   : ml/translcore.ml
+
+  With function name "translate_unified_ops"
 *)
 
 type form = Unary | Binary
@@ -81,13 +89,3 @@ let index_by_path =
 
 let index_by_name =
   entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable
-
-(*
-  Actual implementations of translation are colocated into core modules
-
-  You can find it in:
-  - Type-level : ml/typecore.ml
-  - IR-level   : ml/translcore.ml
-
-  With function name "translate_unified_application"
-*)