diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index a1559a49ab..47dbf26f80 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -212,14 +212,14 @@ let eval_prim x = | _ -> None) | _ -> None -let the_length_of info x = +let the_length_of ~target info x = get_approx info (fun x -> match Flow.Info.def info x with | Some (Constant (String s)) -> Some (Int32.of_int (String.length s)) | Some (Prim (Extern "caml_create_string", [ arg ])) - | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg + | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg | None | Some _ -> None) None (fun u v -> @@ -330,7 +330,7 @@ let constant_js_equal a b = let eval_instr ~target info ((x, loc) as i) = match x with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( - match the_const_of info y, the_const_of info z with + match the_const_of ~target info y, the_const_of ~target info z with | Some e1, Some e2 -> ( match Code.Constant.ocaml_equal e1 e2 with | None -> [ i ] @@ -346,7 +346,7 @@ let eval_instr ~target info ((x, loc) as i) = [ Let (x, c), loc ]) | _ -> [ i ]) | Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> ( - match the_const_of info y, the_const_of info z with + match the_const_of ~target info y, the_const_of ~target info z with | Some e1, Some e2 -> ( match constant_js_equal e1 e2 with | None -> [ i ] @@ -359,7 +359,7 @@ let eval_instr ~target info ((x, loc) as i) = let c = match s with | Pc (String s) -> Some (Int32.of_int (String.length s)) - | Pv v -> the_length_of info v + | Pv v -> the_length_of ~target info v | _ -> None in match c with @@ -410,7 +410,7 @@ let eval_instr ~target info ((x, loc) as 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 info x) in + let prim_args' = List.map prim_args ~f:(fun x -> the_const_of ~target info x) in let res = if List.for_all prim_args' ~f:(function | Some _ -> true diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 138622b4f7..9943166836 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -343,30 +343,31 @@ let the_def_of info x = (* 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 a b = - match a, b with - | Int i, Int j -> Int32.equal i j - | Float a, Float b -> Float.bitwise_equal a b - | NativeString a, NativeString b -> Native_string.equal a b - | String a, String b -> Config.Flag.use_js_string () && String.equal a b - | Int _, Float _ | Float _, Int _ -> false +let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = + match a, b, target with + | Int i, Int j, _ -> Int32.equal i j + | Float a, Float b, `JavaScript -> Float.bitwise_equal a b + | Float _, Float _, `Wasm -> false + | NativeString a, NativeString b, `JavaScript -> Native_string.equal a b + | String a, String b, `JavaScript -> Config.Flag.use_js_string () && String.equal a b + | Int _, Float _, _ | Float _, Int _, _ -> false (* All other values may be distinct objects and thus different by [caml_js_equals]. *) - | String _, _ - | _, String _ - | NativeString _, _ - | _, NativeString _ - | Float_array _, _ - | _, Float_array _ - | Int64 _, _ - | _, Int64 _ - | Int32 _, _ - | _, Int32 _ - | NativeInt _, _ - | _, NativeInt _ - | Tuple _, _ - | _, Tuple _ -> false - -let the_const_of info x = + | String _, _, _ + | _, String _, _ + | NativeString _, _, _ + | _, NativeString _, _ + | Float_array _, _, _ + | _, Float_array _, _ + | Int64 _, _, _ + | _, Int64 _, _ + | Int32 _, _, _ + | _, Int32 _, _ + | NativeInt _, _, _ + | _, NativeInt _, _ + | Tuple _, _, _ + | _, Tuple _, _ -> false + +let the_const_of ~target info x = match x with | Pv x -> get_approx @@ -381,23 +382,23 @@ let the_const_of info x = None (fun u v -> match u, v with - | Some i, Some j when constant_identical i j -> u + | Some i, Some j when constant_identical ~target i j -> u | _ -> None) x | Pc c -> Some c -let the_int info x = - match the_const_of info x with +let the_int ~target info x = + match the_const_of ~target info x with | Some (Int i) -> Some i | _ -> None -let the_string_of info x = - match the_const_of info x with +let the_string_of ~target info x = + match the_const_of info ~target x with | Some (String i) -> Some i | _ -> None -let the_native_string_of info x = - match the_const_of info x with +let the_native_string_of ~target info x = + match the_const_of ~target info x with | Some (NativeString i) -> Some i | _ -> None diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index c2033e0c6c..1dd89af353 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -52,12 +52,15 @@ val get_approx : val the_def_of : Info.t -> Code.prim_arg -> Code.expr option -val the_const_of : Info.t -> Code.prim_arg -> Code.constant option +val the_const_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.constant option -val the_string_of : Info.t -> Code.prim_arg -> string option +val the_string_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> string option -val the_native_string_of : Info.t -> Code.prim_arg -> Code.Native_string.t option +val the_native_string_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.Native_string.t option -val the_int : Info.t -> Code.prim_arg -> int32 option +val the_int : target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> int32 option val f : ?skip_param:bool -> Code.program -> Code.program * Info.t diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index e8fa7b9535..22ffdab84c 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -25,14 +25,14 @@ open Flow let specialize_instr ~target info i = match i, target with | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some "%d" -> ( - match the_int info z with + match the_int ~target info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> Let (x, Prim (Extern "%caml_format_int_special", [ z ]))) | _ -> i) | Let (x, Prim (Extern "%caml_format_int_special", [ z ])), `JavaScript -> ( - match the_int info z with + match the_int ~target info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> i) (* inline the String constant argument so that generate.ml can attempt to parse it *) @@ -43,12 +43,12 @@ let specialize_instr ~target info i = , [ (Pv _ as y) ] ) ) , _ ) when Config.Flag.safe_string () -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some s -> Let (x, Prim (Extern prim, [ Pc (String s) ])) | _ -> i) | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])), `JavaScript -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some s when Primitive.need_named_value s -> Let (x, Prim (Extern prim, [ Pc (String s); z ])) | Some _ -> Let (x, Constant (Int 0l)) @@ -66,7 +66,7 @@ let specialize_instr ~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 info m with + match the_string_of ~target info m with | Some m when Javascript.is_ident m -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> @@ -98,7 +98,7 @@ let specialize_instr ~target info i = match the_def_of info (Pv x) with | Some (Block (_, [| k; v |], _, _)) -> let k = - match the_string_of info (Pv k) with + match the_string_of ~target info (Pv k) with | Some s when String.is_valid_utf_8 s -> Pc (NativeString (Native_string.of_string s)) | Some _ | None -> raise Exit @@ -112,40 +112,40 @@ let specialize_instr ~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 info f with + match the_native_string_of ~target info f with | Some s -> 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 info f with + match the_native_string_of ~target info f with | Some s -> 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 info f with + match the_native_string_of ~target info f with | Some s -> 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 info y with + match the_string_of ~target info y with | Some s when String.is_valid_utf_8 s -> 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 info y with + match the_string_of ~target info y with | Some s -> Let (x, Constant (NativeString (Native_string.of_bytestring s))) | None -> i) | Let (x, Prim (Extern "%int_mul", [ y; z ])), `JavaScript -> ( - match the_int info y, the_int info z with + match the_int ~target info y, the_int ~target info z with | Some j, _ when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _, Some j when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _ -> i) | Let (x, Prim (Extern "%int_div", [ y; z ])), _ -> ( - match the_int info z with + match the_int ~target info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_div", [ y; z ])) | _ -> i) | Let (x, Prim (Extern "%int_mod", [ y; z ])), _ -> ( - match the_int info z with + match the_int ~target info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_mod", [ y; z ])) | _ -> i) | _, _ -> i @@ -208,7 +208,7 @@ let specialize_instrs ~target info l = | "caml_array_get_addr" ) as prim) , [ y; z ] ) ) -> let idx = - match the_int info z with + match the_int ~target info z with | Some idx -> `Cst idx | None -> `Var z in @@ -251,7 +251,7 @@ let specialize_instrs ~target info l = | "caml_array_set_addr" ) as prim) , [ y; z; t ] ) ) -> let idx = - match the_int info z with + match the_int ~target info z with | Some idx -> `Cst idx | None -> `Var z in