remove/replace all remain caml_* primitives

rescript-lang · Sep 10, 2024 · 1ffebf9 · 1ffebf9
1 parent d89201e
commit 1ffebf9
Show file tree

Hide file tree

Showing 70 changed files with 625 additions and 701 deletions.
diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml
@@ -793,18 +793,6 @@ let rec float_equal ?comment (e0 : t) (e1 : t) : t =
 
 let int_equal = float_equal
 
-let string_equal ?comment (e0 : t) (e1 : t) : t =
-  let default () : t = { expression_desc = Bin (EqEqEq, e0, e1); comment } in
-  match (e0.expression_desc, e1.expression_desc) with
-  | Str { txt = a0; delim = d0 }, Str { txt = a1; delim = d1 } when d0 = d1 ->
-    (match str_equal a0 d0 a1 d1 with
-    | Some b -> bool b
-    | None -> default ())
-  | _, _ -> default ()
-
-let is_type_number ?comment (e : t) : t =
-  string_equal ?comment (typeof e) (str "number")
-
 let tag_type = function
   | Ast_untagged_variants.String s -> str s ~delim:DStarJ
   | Int i -> small_int i
@@ -853,11 +841,6 @@ let is_int_tag ?has_null_undefined_other e =
     let check = Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in
     emit_check check
 
-let is_type_string ?comment (e : t) : t =
-  string_equal ?comment (typeof e) (str "string")
-
-let is_type_object (e : t) : t = string_equal (typeof e) (str "object")
-
 (* we are calling [Caml_primitive.primitive_name], since it's under our
    control, we should make it follow the javascript name convention, and
    call plain [dot]
@@ -904,15 +887,26 @@ let to_int32 ?comment (e : J.expression) : J.expression =
   int32_bor ?comment e zero_int_literal
 (* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *)
 
-let string_comp (cmp : J.binop) ?comment (e0 : t) (e1 : t) =
+let string_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) =
   match (e0.expression_desc, e1.expression_desc) with
   | Str { txt = a0; delim = d0 }, Str { txt = a1; delim = d1 } -> (
     match cmp, str_equal a0 d0 a1 d1 with
-      | EqEqEq, Some b -> bool b
-      | NotEqEq, Some b -> bool (b = false)
+      | Ceq, Some b -> bool b
+      | Cneq, Some b -> bool (b = false)
       | _ ->
-        bin ?comment cmp e0 e1)
-  | _ -> bin ?comment cmp e0 e1
+        bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1)
+  | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1
+
+let string_equal ?comment (e0 : t) (e1 : t) : t =
+  string_comp Ceq ?comment e0 e1
+
+let is_type_number ?comment (e : t) : t =
+  string_equal ?comment (typeof e) (str "number")
+
+let is_type_string ?comment (e : t) : t =
+  string_equal ?comment (typeof e) (str "string")
+
+let is_type_object (e : t) : t = string_equal (typeof e) (str "object")
 
 let obj_length ?comment e : t =
   to_int32 { expression_desc = Length (e, Caml_block); comment }

diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli
@@ -269,7 +269,7 @@ val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t
 
 val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t
 
-val string_comp : Js_op.binop -> ?comment:string -> t -> t -> t
+val string_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t
 
 val float_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t
 

diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml
@@ -581,9 +581,13 @@ let has_boolean_type (x : t) =
   | Lprim
       {
         primitive =
-          ( Pnot | Psequand | Psequor | Pisout _ | Pintcomp _ | Pis_not_none
+          ( Pnot | Psequand | Psequor | Pisout _ | Pis_not_none
+          | Pobjcomp _
+          | Pboolcomp _
+          | Pintcomp _ 
           | Pfloatcomp _
-          | Pccall { prim_name = "caml_string_equal" | "caml_string_notequal" }
+          | Pbigintcomp _
+          | Pstringcomp _
             );
         loc;
       } ->

diff --git a/jscomp/core/lam_analysis.ml b/jscomp/core/lam_analysis.ml
@@ -64,9 +64,12 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Pfield _ | Pval_from_option | Pval_from_option_not_nest
       (* NOP The compiler already [t option] is the same as t *)
       | Pduprecord
+      (* generic primitives *)
+      | Pobjcomp _
+      | Pobjorder | Pobjmin | Pobjmax
       (* bool primitives *)
       | Psequand | Psequor | Pnot
-      | Pboolorder | Pboolmin | Pboolmax
+      | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax
       (* int primitives *)
       | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint
       | Plslint | Plsrint | Pasrint | Pintcomp _
@@ -81,7 +84,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Pbigintcomp _ | Pbigintorder | Pbigintmin | Pbigintmax
       (* string primitives *)
       | Pstringlength | Pstringrefu | Pstringrefs
-      | Pstringorder | Pstringmin | Pstringmax
+      | Pstringcomp _ | Pstringorder | Pstringmin | Pstringmax
       (* array primitives *)
       | Pmakearray | Parraylength | Parrayrefu | Parrayrefs
       (* Test if the argument is a block or an immediate integer *)

diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -446,7 +446,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t)
               (Ext_list.append b
                  [
                    S.exp
-                     (E.runtime_call Js_runtime_modules.obj_runtime
+                     (E.runtime_call Js_runtime_modules.object_
                         "update_dummy" [ E.var id; v ]);
                  ]),
             [ S.define_variable ~kind:Variable id (E.dummy_obj tag_info) ] )

diff --git a/jscomp/core/lam_compile_primitive.ml b/jscomp/core/lam_compile_primitive.ml
@@ -251,6 +251,9 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
       match args with [ e1; e2 ] -> E.bigint_op Bxor e1 e2 | _ -> assert false)
   | Pjscomp cmp -> (
       match args with [ l; r ] -> E.js_comp cmp l r | _ -> assert false)
+  | Pboolcomp cmp -> (
+      match args with [ e1; e2 ] -> E.bool_comp cmp e1 e2 | _ -> assert false
+  )
   | Pfloatcomp cmp | Pintcomp cmp -> (
       (* Global Builtin Exception is an int, like
          [Not_found] or [Invalid_argument] ?
@@ -261,6 +264,9 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
   (* List --> stamp = 0
      Assert_false --> stamp = 26
   *)
+  | Pstringcomp cmp -> (
+      match args with [ e1; e2 ] -> E.string_comp cmp e1 e2 | _ -> assert false
+  )
   | Pintoffloat -> (
       match args with [ e ] -> E.to_int32 e | _ -> assert false)
   | Pfloatofint -> Ext_list.singleton_exn args
@@ -304,6 +310,37 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
       match args with
       | [ e; e1 ] -> Js_of_lam_string.ref_string e e1
       | _ -> assert false)
+  (* polymorphic operations *)
+  | Pobjcomp cmp -> (
+      match args with
+      | [ e1; e2 ]
+      when cmp = Ceq && (E.for_sure_js_null_undefined e1 || E.for_sure_js_null_undefined e2)
+      ->
+        E.eq_null_undefined_boolean e1 e2
+      | [ e1; e2 ]
+      when cmp = Cneq && (E.for_sure_js_null_undefined e1 || E.for_sure_js_null_undefined e2)
+      ->
+        E.neq_null_undefined_boolean e1 e2
+      | [ e1; e2 ] ->
+        Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
+        E.runtime_call Js_runtime_modules.object_
+            (Lam_compile_util.runtime_of_comp cmp) args
+      | _ -> assert false)
+  | Pobjorder -> (
+      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
+      match args with
+      | [ a; b ] -> E.runtime_call Js_runtime_modules.object_ "compare" args
+      | _ -> assert false)
+  | Pobjmin -> (
+      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
+      match args with
+      | [ a; b ] -> E.runtime_call Js_runtime_modules.object_ "min" args
+      | _ -> assert false)
+  | Pobjmax -> (
+      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
+      match args with
+      | [ a; b ] -> E.runtime_call Js_runtime_modules.object_ "max" args
+      | _ -> assert false)
   | Pboolorder -> (
       match args with
       | [ { expression_desc = Bool a }; { expression_desc = Bool b } ] ->

diff --git a/jscomp/core/lam_compile_util.ml b/jscomp/core/lam_compile_util.ml
@@ -30,3 +30,12 @@ let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop =
   | Cgt -> Gt
   | Cle -> Le
   | Cge -> Ge
+
+let runtime_of_comp (cmp : Lam_compat.comparison) : string =
+  match cmp with
+  | Ceq -> "equal"
+  | Cneq -> "notequal"
+  | Clt -> "lessthan"
+  | Cgt -> "greaterthan"
+  | Cle -> "lessequal"
+  | Cge -> "greaterequal"
diff --git a/jscomp/core/lam_compile_util.mli b/jscomp/core/lam_compile_util.mli
@@ -25,3 +25,5 @@
 (** Some utilities for lambda compilation*)
 
 val jsop_of_comp : Lam_compat.comparison -> Js_op.binop
+
+val runtime_of_comp : Lam_compat.comparison -> string
diff --git a/jscomp/core/lam_convert.ml b/jscomp/core/lam_convert.ml
@@ -215,9 +215,14 @@ 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
+  | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc
+  | Pobjorder -> prim ~primitive:Pobjorder ~args loc
+  | Pobjmin -> prim ~primitive:Pobjmin ~args loc
+  | Pobjmax -> prim ~primitive:Pobjmax ~args loc
   | Psequand -> prim ~primitive:Psequand ~args loc
   | Psequor -> prim ~primitive:Psequor ~args loc
   | Pnot -> prim ~primitive:Pnot ~args loc
+  | Pboolcomp x -> prim ~primitive:(Pboolcomp x) ~args loc
   | Pboolorder -> prim ~primitive:Pboolorder ~args loc
   | Pboolmin -> prim ~primitive:Pboolmin ~args loc
   | Pboolmax -> prim ~primitive:Pboolmax ~args loc
@@ -238,6 +243,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Pintmax -> prim ~primitive:Pintmax ~args loc
   | Pstringlength -> prim ~primitive:Pstringlength ~args loc
   | Pstringrefu -> prim ~primitive:Pstringrefu ~args loc
+  | Pstringcomp x -> prim ~primitive:(Pstringcomp x) ~args loc
   | Pstringorder -> prim ~primitive:Pstringorder ~args loc
   | Pstringmin -> prim ~primitive:Pstringmin ~args loc
   | Pstringmax -> prim ~primitive:Pstringmax ~args loc
@@ -402,7 +408,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
         match Ext_list.map args convert_aux with
         | [ lhs; rhs ] ->
             prim
-              ~primitive:(Pccall { prim_name = "caml_string_equal" })
+              ~primitive:(Pstringcomp Ceq)
               ~args:[ lam_extension_id loc lhs; rhs ]
               loc
         | _ -> assert false)

diff --git a/jscomp/core/lam_dispatch_primitive.ml b/jscomp/core/lam_dispatch_primitive.ml
@@ -43,85 +43,12 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression
       | None ->
           if prim_name.[0] = '?' then
             String.sub prim_name 1 (String.length prim_name - 1)
-          else if Ext_string.starts_with prim_name "caml_" then
-            String.sub prim_name 5 (String.length prim_name - 5)
-          else assert false (* prim_name *)
+          else prim_name
       | Some x -> x
     in
     E.runtime_call m name args
   in
   match prim_name with
-  | "caml_notequal" -> (
-      match args with
-      | [ a1; b1 ]
-        when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1
-        ->
-          E.neq_null_undefined_boolean a1 b1
-      (* FIXME address_equal *)
-      | _ ->
-          Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
-          call Js_runtime_modules.obj_runtime)
-  | "caml_equal" -> (
-      match args with
-      | [ a1; b1 ]
-        when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1
-        ->
-          E.eq_null_undefined_boolean a1 b1
-      (* FIXME address_equal *)
-      | _ ->
-          Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
-          call Js_runtime_modules.obj_runtime)
-  | "caml_min" | "caml_max" | "caml_compare" | "caml_greaterequal"
-  | "caml_greaterthan" | "caml_lessequal" | "caml_lessthan" | "caml_equal_null"
-  | "caml_equal_undefined" | "caml_equal_nullable" ->
-      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
-      call Js_runtime_modules.obj_runtime
-  (* generated by the compiler, not user facing *)
-  | "caml_string_equal" -> (
-      match args with [ e0; e1 ] -> E.string_equal e0 e1 | _ -> assert false)
-  | "caml_string_notequal" -> (
-      match args with
-      | [ e0; e1 ] -> E.string_comp NotEqEq e0 e1
-      (* TODO: convert to ocaml ones*)
-      | _ -> assert false)
-  | "caml_string_lessequal" -> (
-      match args with [ e0; e1 ] -> E.string_comp Le e0 e1 | _ -> assert false)
-  | "caml_string_lessthan" -> (
-      match args with [ e0; e1 ] -> E.string_comp Lt e0 e1 | _ -> assert false)
-  | "caml_string_greaterequal" -> (
-      match args with [ e0; e1 ] -> E.string_comp Ge e0 e1 | _ -> assert false)
-  | "caml_string_greaterthan" -> (
-      match args with [ e0; e1 ] -> E.string_comp Gt e0 e1 | _ -> assert false)
-  | "caml_bool_notequal" -> (
-      match args with
-      | [ e0; e1 ] -> E.bool_comp Cneq e0 e1
-      (* TODO: specialized in OCaml ones*)
-      | _ -> assert false)
-  | "caml_bool_lessequal" -> (
-      match args with [ e0; e1 ] -> E.bool_comp Cle e0 e1 | _ -> assert false)
-  | "caml_bool_lessthan" -> (
-      match args with [ e0; e1 ] -> E.bool_comp Clt e0 e1 | _ -> assert false)
-  | "caml_bool_greaterequal" -> (
-      match args with [ e0; e1 ] -> E.bool_comp Cge e0 e1 | _ -> assert false)
-  | "caml_bool_greaterthan" -> (
-      match args with [ e0; e1 ] -> E.bool_comp Cgt e0 e1 | _ -> assert false)
-  | "caml_bool_equal" | "caml_bool_equal_null" | "caml_bool_equal_nullable"
-  | "caml_bool_equal_undefined" -> (
-      match args with [ e0; e1 ] -> E.bool_comp Ceq e0 e1 | _ -> assert false)
-  | "caml_int_equal_null" | "caml_int_equal_nullable"
-  | "caml_int_equal_undefined" -> (
-      match args with [ e0; e1 ] -> E.int_comp Ceq e0 e1 | _ -> assert false)
-  | "caml_float_equal_null" | "caml_float_equal_nullable"
-  | "caml_float_equal_undefined" -> (
-      match args with [ e0; e1 ] -> E.float_comp Ceq e0 e1 | _ -> assert false)
-  | "caml_bigint_equal_null" | "caml_bigint_equal_nullable"
-  | "caml_bigint_equal_undefined" -> (
-      match args with [ e0; e1 ] -> E.bigint_comp Ceq e0 e1 | _ -> assert false)
-  | "caml_string_equal_null" | "caml_string_equal_nullable"
-  | "caml_string_equal_undefined" -> (
-      match args with
-      | [ e0; e1 ] -> E.string_comp EqEqEq e0 e1
-      | _ -> assert false)
   (******************************************************************************)
   (************************* customized primitives ******************************)
   (******************************************************************************)
@@ -136,7 +63,7 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression
       like normal one to set the identifier *)
   | "?exn_slot_name" | "?is_extension" -> call Js_runtime_modules.exceptions
   | "?as_js_exn" -> call Js_runtime_modules.caml_js_exceptions
-  | "?obj_dup" -> call Js_runtime_modules.obj_runtime
+  | "?obj_dup" -> call Js_runtime_modules.object_
   | "?obj_tag" -> (
       (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252]
          also now we need do nullary check

diff --git a/jscomp/core/lam_primitive.ml b/jscomp/core/lam_primitive.ml
@@ -57,10 +57,17 @@ type t =
   (* Exceptions *)
   | Praise
 
+  (* object primitives *)
+  | Pobjcomp of Lam_compat.comparison
+  | Pobjorder
+  | Pobjmin
+  | Pobjmax
+
   (* Boolean primitives *)
   | Psequand
   | Psequor
   | Pnot
+  | Pboolcomp of Lam_compat.comparison
   | Pboolorder
   | Pboolmin
   | Pboolmax
@@ -122,6 +129,7 @@ type t =
   | Pstringrefu
   | Pstringrefs
   | Pstringadd
+  | Pstringcomp of Lam_compat.comparison
   | Pstringorder
   | Pstringmin
   | Pstringmax
@@ -191,10 +199,15 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
   match lhs with
   | Pwrap_exn
   | Praise
+  (* generic comparison *)
+  | Pobjorder
+  | Pobjmin
+  | Pobjmax
   (* bool primitives *)
   | Psequand
   | Psequor
   | Pnot
+  | Pboolcomp _
   | Pboolorder
   | Pboolmin
   | Pboolmax
@@ -247,6 +260,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
   | Pstringrefu
   | Pstringrefs
   | Pstringadd
+  | Pstringcomp _
   | Pstringorder
   | Pstringmin
   | Pstringmax
@@ -317,6 +331,10 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
       match rhs with
       | Pjs_object_create obj_create1 -> obj_create = obj_create1
       | _ -> false)
+  | Pobjcomp comparison -> (
+      match rhs with
+      | Pobjcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1
+      | _ -> false)
   | Pintcomp comparison -> (
       match rhs with
       | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1
Original file line number	Diff line number	Diff line change
Expand Up		@@ -25,3 +25,5 @@
		(** Some utilities for lambda compilation*)

		val jsop_of_comp : Lam_compat.comparison -> Js_op.binop

		val runtime_of_comp : Lam_compat.comparison -> string