diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 2e191cafb..e766b07b1 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -1170,7 +1170,7 @@ let init () = let l = [ "caml_ensure_stack_capacity", "%identity"; "caml_callback", "caml_trampoline" ] in - + Primitive.register "caml_make_array" `Mutable None None; let l = if Config.Flag.effects () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 21712fd03..799027de8 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -198,6 +198,7 @@ let rec block_escape st x = | Immutable -> () | Maybe_mutable -> Code.Var.ISet.add st.possibly_mutable y); Array.iter l ~f:(fun z -> block_escape st z) + | Expr (Prim (Extern "caml_make_array", [ Pv y ])) -> block_escape st y | _ -> Code.Var.ISet.add st.possibly_mutable y)) (Var.Tbl.get st.known_origins x) @@ -207,6 +208,7 @@ let expr_escape st _x e = | Apply { args; _ } -> List.iter args ~f:(fun x -> block_escape st x) | Prim (Array_get, [ Pv x; _ ]) -> block_escape st x | Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> () + | Prim (Extern "caml_make_array", [ Pv _ ]) -> () | Prim (Extern name, l) -> let ka = match Primitive.kind_args name with @@ -231,6 +233,11 @@ let expr_escape st _x e = | Expr (Constant (Tuple _)) -> () | Expr (Block (_, a, _, _)) -> Array.iter a ~f:(fun x -> block_escape st x) + | Expr (Prim (Extern "caml_make_array", [ Pv y ])) -> ( + match st.defs.(Var.idx y) with + | Expr (Block (_, a, _, _)) -> + Array.iter a ~f:(fun x -> block_escape st x) + | _ -> assert false) | _ -> block_escape st v) | Pv v, `Object_literal -> ( match st.defs.(Var.idx v) with @@ -403,6 +410,16 @@ let the_string_of ~target info x = let the_native_string_of ~target info x = match the_const_of ~target info x with | Some (NativeString i) -> Some i + | Some (String i) -> Some (Native_string.of_bytestring i) + | _ -> None + +let the_block_contents_of info x = + match the_def_of info x with + | Some (Block (_, a, _, _)) -> Some a + | Some (Prim (Extern "caml_make_array", [ x ])) -> ( + match the_def_of info x with + | Some (Block (_, a, _, _)) -> Some a + | _ -> None) | _ -> None (*XXX Maybe we could iterate? *) diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index 20271a4e3..32801ac30 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -61,6 +61,8 @@ val the_string_of : val the_native_string_of : target:[ `JavaScript | `Wasm ] -> 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 + val the_int : target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Targetint.t option diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 4fa7c7776..f1a28ef6a 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -55,22 +55,22 @@ let specialize_instr ~target info i = | Some _ -> Let (x, Constant (Int Targetint.zero)) | None -> i) | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in 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 | Some m when Javascript.is_ident m -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let ( x @@ -79,11 +79,11 @@ let specialize_instr ~target info i = , o :: Pc (NativeString (Native_string.of_string m)) :: Array.to_list a ) ) - | _ -> i) + | None -> i) | _ -> i) | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i)