From b7a412ea05e24453009a9133348ea1e50226abbf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 29 Apr 2025 18:17:52 +0200 Subject: [PATCH 1/3] Flow.the_const_of: allow to use different comparison functions Whether two constants should be considered equal depends on the context in which they are used. --- compiler/lib/eval.ml | 35 ++++++++++++++++++++-- compiler/lib/flow.ml | 56 +++++++++-------------------------- compiler/lib/flow.mli | 11 +++---- compiler/lib/specialize_js.ml | 22 +++++++------- 4 files changed, 63 insertions(+), 61 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index bc30fd18c7..3a380cbde1 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -467,10 +467,32 @@ let constant_js_equal a b = | Tuple _, _ | _, Tuple _ -> None +(* [eval_prim] does not distinguish the two constants *) +let constant_equal a b = + match a, b with + | Int i, Int j -> Targetint.equal i j + | Float a, Float b -> Int64.equal a b + | NativeString a, NativeString b -> Native_string.equal a b + | String a, String b -> String.equal a b + | Int32 a, Int32 b -> Int32.equal a b + | NativeInt a, NativeInt b -> Int32.equal a b + | Int64 a, Int64 b -> Int64.equal a b + (* We don't need to compare other constants, so let's just return false. *) + | Tuple _, Tuple _ -> false + | Float_array _, Float_array _ -> false + | (Int _ | Float _ | Int64 _ | Int32 _ | NativeInt _), _ -> false + | (String _ | NativeString _), _ -> false + | (Float_array _ | Tuple _), _ -> false + let eval_instr update_count inline_constant ~target info i = match i with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( - match the_const_of ~target info y, the_const_of ~target info z with + let eq e1 e2 = + match Code.Constant.ocaml_equal e1 e2 with + | None -> false + | Some e -> e + in + match the_const_of ~eq info y, the_const_of ~eq info z with | Some e1, Some e2 -> ( match Code.Constant.ocaml_equal e1 e2 with | None -> [ i ] @@ -487,7 +509,12 @@ let eval_instr update_count inline_constant ~target info i = [ Let (x, c) ]) | _ -> [ i ]) | Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> ( - match the_const_of ~target info y, the_const_of ~target info z with + let eq e1 e2 = + match constant_js_equal e1 e2 with + | None -> false + | Some e -> e + in + match the_const_of ~eq info y, the_const_of ~eq info z with | Some e1, Some e2 -> ( match constant_js_equal e1 e2 with | None -> [ i ] @@ -586,7 +613,9 @@ let eval_instr update_count inline_constant ~target info i = | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) -> [ i ] (* We need that the arguments to this primitives remain variables *) | Let (x, Prim (prim, prim_args)) -> ( - let prim_args' = List.map prim_args ~f:(fun x -> the_const_of ~target info x) in + let prim_args' = + List.map prim_args ~f:(fun x -> the_const_of ~eq:constant_equal info x) + in let res = if List.for_all prim_args' ~f:(function diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 94d159a2b3..8a59cff087 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -360,53 +360,25 @@ let the_def_of info x = x | Pc c -> Some (Constant c) -(* If [constant_identical a b = true], then the two values cannot be - distinguished, i.e., they are not different objects (and [caml_js_equals a b - = true]) and if both are floats, they are bitwise equal. *) -let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = - match a, b, target with - | Int i, Int j, _ -> Targetint.equal i j - | Float a, Float b, `JavaScript -> Int64.equal a b - | Float _, Float _, `Wasm -> false - | NativeString a, NativeString b, `JavaScript -> Native_string.equal a b - | NativeString _, NativeString _, `Wasm -> - false - (* Native strings are boxed (JavaScript objects) in Wasm and are - possibly different objects *) - | String a, String b, `JavaScript -> Config.Flag.use_js_string () && String.equal a b - | String _, String _, `Wasm -> - false (* Strings are boxed in Wasm and are possibly different objects *) - | Int32 _, Int32 _, `Wasm -> - false (* [Int32]s are boxed in Wasm and are possibly different objects *) - | Int32 a, Int32 b, `JavaScript -> Int32.equal a b - | NativeInt _, NativeInt _, `Wasm -> - false (* [NativeInt]s are boxed in Wasm and are possibly different objects *) - | NativeInt a, NativeInt b, `JavaScript -> Int32.equal a b - (* All other values may be distinct objects and thus different by [caml_js_equals]. *) - | Int64 _, Int64 _, _ -> false - | Tuple _, Tuple _, _ -> false - | Float_array _, Float_array _, _ -> false - | (Int _ | Float _ | Int64 _ | Int32 _ | NativeInt _), _, _ -> false - | (String _ | NativeString _), _, _ -> false - | (Float_array _ | Tuple _), _, _ -> false - -let the_const_of ~target info x = +let the_const_of ~eq info x = match x with | Pv x -> get_approx info (fun x -> - match info.info_defs.(Var.idx x), target with - | Expr (Constant ((Float _ | Int _ | NativeString _) as c)), _ -> Some c - | Expr (Constant ((Int32 _ | NativeInt _) as c)), `JavaScript -> Some c - | Expr (Constant (String _ as c)), _ when Config.Flag.safe_string () -> Some c - | Expr (Constant c), _ -> - if Var.ISet.mem info.info_possibly_mutable x then None else Some c + match info.info_defs.(Var.idx x) with + | Expr + (Constant + ((Float _ | Int _ | Int32 _ | Int64 _ | NativeInt _ | NativeString _) as + c)) -> Some c + | Expr (Constant c) + when Config.Flag.safe_string () + || not (Var.ISet.mem info.info_possibly_mutable x) -> Some c | _ -> None) None (fun u v -> match u, v with - | Some i, Some j when constant_identical ~target i j -> u + | Some i, Some j when eq i j -> u | _ -> None) x | Pc c -> Some c @@ -429,13 +401,13 @@ let the_int info x = | Pc (Int c) -> Some c | Pc _ -> None -let the_string_of ~target info x = - match the_const_of info ~target x with +let the_string_of info x = + match the_const_of ~eq:(fun _ _ -> false) info x with | Some (String i) -> Some i | _ -> None -let the_native_string_of ~target info x = - match the_const_of ~target info x with +let the_native_string_of info x = + match the_const_of ~eq:(fun _ _ -> false) info x with | Some (NativeString i) -> Some i | Some (String i) -> (* This function is used to optimize the primitives that access diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index 06975e6213..d7c49f621e 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -53,13 +53,14 @@ val get_approx : val the_def_of : Info.t -> Code.prim_arg -> Code.expr option val the_const_of : - target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.constant option + eq:(Code.constant -> Code.constant -> bool) + -> Info.t + -> Code.prim_arg + -> Code.constant option -val the_string_of : - target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> string option +val the_string_of : Info.t -> Code.prim_arg -> string option -val the_native_string_of : - target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.Native_string.t option +val the_native_string_of : Info.t -> Code.prim_arg -> Code.Native_string.t option val the_block_contents_of : Info.t -> Code.prim_arg -> Code.Var.t array option diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index ceeaaf5b7c..59fb299669 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -34,7 +34,7 @@ let specialize_instr opt_count ~target info i = (* We can implement the special case where the format string is "%s" in JavaScript in a concise and efficient way with [""+x]. It does not make as much sense in Wasm to have a special case for this. *) - match the_string_of ~target info y with + match the_string_of info y with | Some "%d" -> ( incr opt_count; match the_int info z with @@ -53,15 +53,15 @@ let specialize_instr opt_count ~target info i = , Prim ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) , [ (Pv _ as y) ] ) ) - , target ) -> ( - match the_string_of ~target info y with + , _ ) -> ( + match the_string_of info y with | Some s -> incr opt_count; Let (x, Prim (Extern prim, [ Pc (String s) ])) | _ -> i) | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ (Pv _ as y); z ])), _ -> ( - match the_string_of ~target info y with + match the_string_of info y with | Some s when Primitive.need_named_value s -> incr opt_count; Let (x, Prim (Extern prim, [ Pc (String s); z ])) @@ -84,7 +84,7 @@ let specialize_instr opt_count ~target info i = Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> ( - match the_string_of ~target info m with + match the_string_of info m with | Some m when Javascript.is_ident m -> ( match the_block_contents_of info a with | Some a -> @@ -118,7 +118,7 @@ let specialize_instr opt_count ~target info i = match the_def_of info (Pv x) with | Some (Block (_, [| k; v |], _, _)) -> let k = - match the_string_of ~target info (Pv k) with + match the_string_of info (Pv k) with | Some s when String.is_valid_utf_8 s -> Pc (NativeString (Native_string.of_string s)) | Some _ | None -> raise Exit @@ -133,32 +133,32 @@ let specialize_instr opt_count ~target info i = Let (x, Prim (Extern "%caml_js_opt_object", List.flatten (Array.to_list a))) with Exit -> i) | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])), _ -> ( - match the_native_string_of ~target info f with + match the_native_string_of info f with | Some s -> incr opt_count; Let (x, Prim (Extern "caml_js_get", [ o; Pc (NativeString s) ])) | _ -> i) | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])), _ -> ( - match the_native_string_of ~target info f with + match the_native_string_of info f with | Some s -> incr opt_count; Let (x, Prim (Extern "caml_js_set", [ o; Pc (NativeString s); v ])) | _ -> i) | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])), _ -> ( - match the_native_string_of ~target info f with + match the_native_string_of info f with | Some s -> incr opt_count; Let (x, Prim (Extern "caml_js_delete", [ o; Pc (NativeString s) ])) | _ -> i) | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])), _ -> ( - match the_string_of ~target info y with + match the_string_of info y with | Some s when String.is_valid_utf_8 s -> incr opt_count; Let (x, Constant (NativeString (Native_string.of_string s))) | Some _ | None -> i) | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])), _ -> ( - match the_string_of ~target info y with + match the_string_of info y with | Some s -> incr opt_count; Let (x, Constant (NativeString (Native_string.of_bytestring s))) From 7bd99beda4c53316f860630364f711e45a400844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 6 May 2025 12:02:56 +0200 Subject: [PATCH 2/3] CR --- compiler/lib/flow.ml | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 8a59cff087..adf814ec9e 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -352,7 +352,7 @@ let the_def_of info x = match info.info_defs.(Var.idx x) with | Expr (Constant (Float _ | Int _ | NativeString _) as e) -> Some e | Expr (Constant (Int32 _ | NativeInt _) as e) -> Some e - | Expr (Constant (String _) as e) when Config.Flag.safe_string () -> Some e + | Expr (Constant _ as e) when Config.Flag.safe_string () -> Some e | Expr e -> if Var.ISet.mem info.info_possibly_mutable x then None else Some e | _ -> None) None @@ -369,11 +369,16 @@ let the_const_of ~eq info x = match info.info_defs.(Var.idx x) with | Expr (Constant - ((Float _ | Int _ | Int32 _ | Int64 _ | NativeInt _ | NativeString _) as - c)) -> Some c - | Expr (Constant c) - when Config.Flag.safe_string () - || not (Var.ISet.mem info.info_possibly_mutable x) -> Some c + (( Float _ + | Int _ + | Int32 _ + | Int64 _ + | NativeInt _ + | NativeString _ + | Float_array _ ) as c)) -> Some c + | Expr (Constant (String _ as c)) + when not (Var.ISet.mem info.info_possibly_mutable x) -> Some c + | Expr (Constant c) when Config.Flag.safe_string () -> Some c | _ -> None) None (fun u v -> @@ -401,13 +406,20 @@ let the_int info x = | Pc (Int c) -> Some c | Pc _ -> None +let string_equal a b = + match a, b with + | NativeString a, NativeString b -> Native_string.equal a b + | String a, String b -> String.equal a b + (* We don't need to compare other constants, so let's just return false. *) + | _ -> false + let the_string_of info x = - match the_const_of ~eq:(fun _ _ -> false) info x with + match the_const_of ~eq:string_equal info x with | Some (String i) -> Some i | _ -> None let the_native_string_of info x = - match the_const_of ~eq:(fun _ _ -> false) info x with + match the_const_of ~eq:string_equal info x with | Some (NativeString i) -> Some i | Some (String i) -> (* This function is used to optimize the primitives that access From f57c8f73a791d4b12276e4c354587407047e757d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 6 May 2025 18:06:14 +0200 Subject: [PATCH 3/3] Changes --- CHANGES.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index d85b4a3e8a..1d378f3bdb 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,7 +5,7 @@ * Compiler: use a Wasm text files preprocessor (#1822) * Compiler: support for OCaml 4.14.3+trunk (#1844) * Compiler: optimize compilation of switches -* Compiler: evaluate statically more primitives (#1915) +* Compiler: evaluate statically more primitives (#1912, #1915, #1965) * Runtime: use es6 class (#1840) * Runtime: support more Unix functions (#1829) * Runtime: remove polyfill for Map to simplify MlObjectTable implementation (#1846) @@ -24,7 +24,6 @@ * Ppx: allow "function" in object literals (#1897) * Lib: make the Wasm version of Json.output work with native ints and JavaScript objects (#1872) * Compiler: add the `--empty-sourcemap` flag -* Compiler: static evaluation of more primitives (#1912) * Compiler: faster compilation by stopping sooner when optimizations become unproductive (#1939) * Compiler: improve debug/sourcemap location of closures (#1947) * Compiler: improve tailcall optimization (#1943)