From 65a9948215b120bf92bbc5c6e1074f24ffb0ca3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 11 Jun 2024 16:29:18 +0200 Subject: [PATCH 1/5] Refactor distinction between integer types --- compiler/lib/code.ml | 65 ++++++++++++++++------ compiler/lib/code.mli | 4 +- compiler/lib/effects.ml | 10 ++-- compiler/lib/eval.ml | 85 +++++++++++++++-------------- compiler/lib/flow.ml | 2 +- compiler/lib/generate.ml | 6 +- compiler/lib/generate_closure.ml | 8 +-- compiler/lib/ocaml_compiler.ml | 18 +++--- compiler/lib/parse_bytecode.ml | 59 +++++++++++--------- compiler/lib/specialize_js.ml | 4 +- compiler/lib/wasm/wa_core_target.ml | 8 +-- compiler/lib/wasm/wa_gc_target.ml | 12 ++-- compiler/lib/wasm/wa_generate.ml | 4 +- 13 files changed, 166 insertions(+), 119 deletions(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index c4b47bd19..b7143e3f2 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -284,9 +284,11 @@ type constant = | NativeString of Native_string.t | Float of float | Float_array of float array + | Int of int32 + | Int32 of int32 | Int64 of int64 + | NativeInt of nativeint | Tuple of int * constant array * array_or_not - | Int of int_kind * int32 let rec constant_equal a b = match a, b with @@ -304,26 +306,59 @@ let rec constant_equal a b = | Some s, Some c -> same := Some (s && c) done; !same + | Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b) | Int64 a, Int64 b -> Some (Int64.equal a b) + | NativeInt a, NativeInt b -> Some (Nativeint.equal a b) | Float_array a, Float_array b -> Some (Array.equal Float.equal a b) - | Int (k, a), Int (k', b) -> if Poly.(k = k') then Some (Int32.equal a b) else None | Float a, Float b -> Some (Float.equal a b) | String _, NativeString _ | NativeString _, String _ -> None | Int _, Float _ | Float _, Int _ -> None | Tuple ((0 | 254), _, _), Float_array _ -> None | Float_array _, Tuple ((0 | 254), _, _) -> None - | Tuple _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Float_array _) -> + | ( Tuple _ + , ( String _ + | NativeString _ + | Int64 _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Float_array _ ) ) -> Some false + | ( Float_array _ + , ( String _ + | NativeString _ + | Int64 _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Tuple _ ) ) -> Some false + | ( String _ + , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> Some false - | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) -> - Some false - | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false - | NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false - | Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) -> + | ( NativeString _ + , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> Some false + | ( Int64 _ + , ( String _ + | NativeString _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Tuple _ + | Float_array _ ) ) -> Some false | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> Some false - | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> + | ( (Int _ | Int32 _ | NativeInt _) + , (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) -> Some false + (* Note: the following cases should not occur when compiling to Javascript *) + | Int _, (Int32 _ | NativeInt _) + | Int32 _, (Int _ | NativeInt _) + | NativeInt _, (Int _ | Int32 _) + | (Int32 _ | NativeInt _), Float _ + | Float _, (Int32 _ | NativeInt _) -> None type loc = | No @@ -413,7 +448,10 @@ module Print = struct Format.fprintf f "%.12g" a.(i) done; Format.fprintf f "|]" + | Int i -> Format.fprintf f "%ld" i + | Int32 i -> Format.fprintf f "%ldl" i | Int64 i -> Format.fprintf f "%LdL" i + | NativeInt i -> Format.fprintf f "%ndn" i | Tuple (tag, a, _) -> ( Format.fprintf f "<%d>" tag; match Array.length a with @@ -430,15 +468,6 @@ module Print = struct constant f a.(i) done; Format.fprintf f ")") - | Int (k, i) -> - Format.fprintf - f - "%ld%s" - i - (match k with - | Regular -> "" - | Int32 -> "l" - | Native -> "n") let arg f a = match a with diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 8a22b98bf..16af48737 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -162,9 +162,11 @@ type constant = | NativeString of Native_string.t | Float of float | Float_array of float array + | Int of int32 + | Int32 of int32 (** Only produced when compiling to WebAssembly. *) | Int64 of int64 + | NativeInt of nativeint (** Only produced when compiling to WebAssembly. *) | Tuple of int * constant array * array_or_not - | Int of int_kind * int32 val constant_equal : constant -> constant -> bool option diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 7424b6bdd..66c79a3ed 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -300,7 +300,7 @@ let cps_branch ~st ~src (pc, args) loc = (* We are jumping to a block that is also used as a continuation. We pass it a dummy argument. *) let x = Var.fresh () in - [ x ], [ Let (x, Constant (Int (Regular, 0l))), noloc ] + [ x ], [ Let (x, Constant (Int 0l)), noloc ] else args, [] in (* We check the stack depth only for backward edges (so, at @@ -402,7 +402,7 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k : ( x' , Prim ( Extern "caml_maybe_attach_backtrace" - , [ Pv x; Pc (Int (Regular, if force then 1l else 0l)) ] ) ) + , [ Pv x; Pc (Int (if force then 1l else 0l)) ] ) ) , noloc ) ] in @@ -480,12 +480,12 @@ let cps_instr ~st (instr : instr) : instr = Let (x, Closure (params @ [ k ], cont)) | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with - | Pc (Int (_, a)) -> + | Pc (Int a) -> Let ( x , Prim ( Extern "caml_alloc_dummy_function" - , [ size; Pc (Int (Regular, Int32.succ a)) ] ) ) + , [ size; Pc (Int (Int32.succ a)) ] ) ) | _ -> assert false) | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> (* At the moment, we turn into CPS any function not called with @@ -563,7 +563,7 @@ let cps_block ~st ~k pc block = [ arg; k' ] loc) | Prim (Extern "%perform", [ Pv effect ]) -> - perform_effect ~effect ~continuation:(Pc (Int (Regular, 0l))) loc + perform_effect ~effect ~continuation:(Pc (Int 0l)) loc | Prim (Extern "%reperform", [ Pv effect; continuation ]) -> perform_effect ~effect ~continuation loc | _ -> None diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 5a2f5fb93..e61bd48a5 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -33,22 +33,22 @@ module Int = Int32 let int_binop l w f = match l with - | [ Int (_, i); Int (_, j) ] -> Some (Int (Regular, w (f i j))) + | [ Int i; Int j ] -> Some (Int (w (f i j))) | _ -> None let shift l w t f = match l with - | [ Int (_, i); Int (_, j) ] -> - Some (Int (Regular, w (f (t i) (Int32.to_int j land 0x1f)))) + | [ Int i; Int j ] -> + Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) | _ -> None let float_binop_aux l f = let args = match l with | [ Float i; Float j ] -> Some (i, j) - | [ Int (_, i); Int (_, j) ] -> Some (Int32.to_float i, Int32.to_float j) - | [ Int (_, i); Float j ] -> Some (Int32.to_float i, j) - | [ Float i; Int (_, j) ] -> Some (i, Int32.to_float j) + | [ Int i; Int j ] -> Some (Int32.to_float i, Int32.to_float j) + | [ Int i; Float j ] -> Some (Int32.to_float i, j) + | [ Float i; Int j ] -> Some (i, Int32.to_float j) | _ -> None in match args with @@ -63,25 +63,25 @@ let float_binop l f = let float_unop l f = match l with | [ Float i ] -> Some (Float (f i)) - | [ Int (_, i) ] -> Some (Float (f (Int32.to_float i))) + | [ Int i ] -> Some (Float (f (Int32.to_float i))) | _ -> None let float_binop_bool l f = match float_binop_aux l f with - | Some true -> Some (Int (Regular, 1l)) - | Some false -> Some (Int (Regular, 0l)) + | Some true -> Some (Int 1l) + | Some false -> Some (Int 0l) | None -> None -let bool b = Some (Int (Regular, if b then 1l else 0l)) +let bool b = Some (Int (if b then 1l else 0l)) let eval_prim ~target x = match x with - | Not, [ Int (_, i) ] -> bool Int32.(i = 0l) - | Lt, [ Int (_, i); Int (_, j) ] -> bool Int32.(i < j) - | Le, [ Int (_, i); Int (_, j) ] -> bool Int32.(i <= j) - | Eq, [ Int (_, i); Int (_, j) ] -> bool Int32.(i = j) - | Neq, [ Int (_, i); Int (_, j) ] -> bool Int32.(i <> j) - | Ult, [ Int (_, i); Int (_, j) ] -> bool (Int32.(j < 0l) || Int32.(i < j)) + | Not, [ Int i ] -> bool Int32.(i = 0l) + | Lt, [ Int i; Int j ] -> bool Int32.(i < j) + | Le, [ Int i; Int j ] -> bool Int32.(i <= j) + | Eq, [ Int i; Int j ] -> bool Int32.(i = j) + | Neq, [ Int i; Int j ] -> bool Int32.(i <> j) + | Ult, [ Int i; Int j ] -> bool (Int32.(j < 0l) || Int32.(i < j)) | Extern name, l -> ( let name = Primitive.resolve name in let wrap = @@ -94,7 +94,7 @@ let eval_prim ~target x = | "%int_add", _ -> int_binop l wrap Int.add | "%int_sub", _ -> int_binop l wrap Int.sub | "%direct_int_mul", _ -> int_binop l wrap Int.mul - | "%direct_int_div", [ _; Int (_, 0l) ] -> None + | "%direct_int_div", [ _; Int 0l ] -> None | "%direct_int_div", _ -> int_binop l wrap Int.div | "%direct_int_mod", _ -> int_binop l wrap Int.rem | "%int_and", _ -> int_binop l wrap Int.logand @@ -110,7 +110,7 @@ let eval_prim ~target x = | `Wasm -> fun i -> Int.logand i 0x7fffffffl) Int.shift_right_logical | "%int_asr", _ -> shift l wrap Fun.id Int.shift_right - | "%int_neg", [ Int (_, i) ] -> Some (Int (Regular, Int.neg i)) + | "%int_neg", [ Int i ] -> Some (Int (Int.neg i)) (* float *) | "caml_eq_float", _ -> float_binop_bool l Float.( = ) | "caml_neq_float", _ -> float_binop_bool l Float.( <> ) @@ -123,9 +123,9 @@ let eval_prim ~target x = | "caml_mul_float", _ -> float_binop l ( *. ) | "caml_div_float", _ -> float_binop l ( /. ) | "caml_fmod_float", _ -> float_binop l mod_float - | "caml_int_of_float", [ Float f ] -> Some (Int (Regular, Int.of_float f)) - | "to_int", [ Float f ] -> Some (Int (Regular, Int.of_float f)) - | "to_int", [ Int (_, i) ] -> Some (Int (Regular, i)) + | "caml_int_of_float", [ Float f ] -> Some (Int (Int.of_float f)) + | "to_int", [ Float f ] -> Some (Int (Int.of_float f)) + | "to_int", [ Int i ] -> Some (Int i) (* Math *) | "caml_neg_float", _ -> float_unop l ( ~-. ) | "caml_abs_float", _ -> float_unop l abs_float @@ -142,10 +142,10 @@ let eval_prim ~target x = | "caml_sin_float", _ -> float_unop l sin | "caml_sqrt_float", _ -> float_unop l sqrt | "caml_tan_float", _ -> float_unop l tan - | ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int (_, pos) ] -> + | ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int pos ] -> let pos = Int32.to_int pos in if Config.Flag.safe_string () && pos >= 0 && pos < String.length s - then Some (Int (Regular, Int32.of_int (Char.code s.[pos]))) + then Some (Int (Int32.of_int (Char.code s.[pos]))) else None | "caml_string_equal", [ String s1; String s2 ] -> bool (String.equal s1 s2) | "caml_string_notequal", [ String s1; String s2 ] -> @@ -154,16 +154,15 @@ let eval_prim ~target x = match get_static_env s with | Some env -> Some (String env) | None -> None) - | "caml_sys_const_word_size", [ _ ] -> Some (Int (Regular, 32l)) + | "caml_sys_const_word_size", [ _ ] -> Some (Int 32l) | "caml_sys_const_int_size", [ _ ] -> Some (Int - ( Regular - , match target with - | `JavaScript -> 32l - | `Wasm -> 31l )) - | "caml_sys_const_big_endian", [ _ ] -> Some (Int (Regular, 0l)) - | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int (Regular, 0l)) + (match target with + | `JavaScript -> 32l + | `Wasm -> 31l )) + | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) + | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int 0l) | _ -> None) | _ -> None @@ -195,8 +194,8 @@ let is_int ~target info x = info (fun x -> match info.info_defs.(Var.idx x) with - | Expr (Constant (Int (Regular, _))) -> Y - | Expr (Constant (Int _)) -> ( + | Expr (Constant (Int _)) -> Y + | Expr (Constant (Int32 _ | NativeInt _)) -> ( match target with | `JavaScript -> Y | `Wasm -> N) @@ -209,8 +208,8 @@ let is_int ~target info x = | N, N -> N | _ -> Unknown) x - | Pc (Int (Regular, _)) -> Y - | Pc (Int _) -> ( + | Pc (Int _) -> Y + | Pc (Int32 _ | NativeInt _) -> ( match target with | `JavaScript -> Y | `Wasm -> N) @@ -247,7 +246,7 @@ let the_cont_of info x (a : cont array) = (fun x -> match info.info_defs.(Var.idx x) with | Expr (Prim (Extern "%direct_obj_tag", [ b ])) -> the_tag_of info b get - | Expr (Constant (Int (_, j))) -> get (Int32.to_int j) + | Expr (Constant (Int j)) -> get (Int32.to_int j) | _ -> None) None (fun u v -> @@ -265,7 +264,7 @@ let eval_instr ~target info ((x, loc) as i) = | None -> [ i ] | Some c -> let c = if c then 1l else 0l in - let c = Constant (Int (Regular, c)) in + let c = Constant (Int c) in Flow.update_def info x c; [ Let (x, c), loc ]) | _ -> [ i ]) @@ -279,7 +278,7 @@ let eval_instr ~target info ((x, loc) as i) = match c with | None -> [ i ] | Some c -> - let c = Constant (Int (Regular, c)) in + let c = Constant (Int c) in Flow.update_def info x c; [ Let (x, c), loc ]) | Let @@ -302,13 +301,13 @@ let eval_instr ~target info ((x, loc) as i) = | Unknown -> [ i ] | (Y | N) as b -> let b = if Poly.(b = N) then 0l else 1l in - let c = Constant (Int (Regular, b)) in + let c = Constant (Int b) in Flow.update_def info x c; [ Let (x, c), loc ]) | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> ( match the_tag_of info y (fun x -> Some x) with | Some tag -> - let c = Constant (Int (Regular, Int32.of_int tag)) in + let c = Constant (Int (Int32.of_int tag)) in Flow.update_def info x c; [ Let (x, c), loc ] | None -> [ i ]) @@ -374,11 +373,13 @@ let the_cond_of info x = get_approx info (fun x -> - match info.info_defs.(Var.idx x) with - | Expr (Constant (Int (_, 0l))) -> Zero - | Expr + match Flow.Info.def info x with + | Some (Constant (Int 0l)) -> Zero + | Some (Constant ( Int _ + | Int32 _ + | NativeInt _ | Float _ | Tuple _ | String _ diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index ebf5773f5..b5ee88b9a 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -344,7 +344,7 @@ let the_const_of info x = let the_int info x = match the_const_of info x with - | Some (Int (_, i)) -> Some i + | Some (Int i) -> Some i | _ -> None let the_string_of info x = diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 45859f1d7..5dcf214e4 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -451,7 +451,7 @@ let rec constant_rec ~ctx x level instrs = let constant_max_depth = Config.Param.constant_max_depth () in let rec detect_list n acc = function | Tuple (0, [| x; l |], _) -> detect_list (succ n) (x :: acc) l - | Int (_, 0l) -> if n > constant_max_depth then Some acc else None + | Int 0l -> if n > constant_max_depth then Some acc else None | _ -> None in match detect_list 0 [] x with @@ -488,7 +488,9 @@ let rec constant_rec ~ctx x level instrs = else List.rev l, instrs in Mlvalue.Block.make ~tag ~args:l, instrs) - | Int (_, i) -> int32 i, instrs + | Int i -> int32 i, instrs + | Int32 _ | NativeInt _ -> + assert false (* Should not be produced when compiling to Javascript *) let constant ~ctx x level = let expr, instr = constant_rec ~ctx x level [] in diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index 9a638169a..3094ac98c 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -107,7 +107,7 @@ module Trampoline = struct ; body = [ ( Let ( counter_plus_1 - , Prim (Extern "%int_add", [ Pv counter; Pc (Int (Regular, 1l)) ]) ) + , Prim (Extern "%int_add", [ Pv counter; Pc (Int 1l) ]) ) , noloc ) ; Let (return, Apply { f; args = counter_plus_1 :: args; exact = true }), loc ] @@ -123,7 +123,7 @@ module Trampoline = struct ( new_args , Prim ( Extern "%js_array" - , Pc (Int (Regular, 0l)) :: List.map args ~f:(fun x -> Pv x) ) ) + , Pc (Int 0l) :: List.map args ~f:(fun x -> Pv x) ) ) , noloc ) ; Let (return, Prim (Extern "caml_trampoline_return", [ Pv f; Pv new_args ])), loc ] @@ -142,7 +142,7 @@ module Trampoline = struct ; Let (result2, Prim (Extern "caml_trampoline", [ Pv result1 ])), noloc ] | Some counter -> - [ Let (counter, Constant (Int (Regular, 0l))), noloc + [ Let (counter, Constant (Int 0l)), noloc ; Let (result1, Apply { f; args = counter :: args; exact = true }), loc ; Let (result2, Prim (Extern "caml_trampoline", [ Pv result1 ])), noloc ]) @@ -248,7 +248,7 @@ module Trampoline = struct , [ Pv counter ; Pc (Int - (Regular, Int32.of_int tailcall_max_depth)) + (Int32.of_int tailcall_max_depth)) ] ) ) , noloc ) in diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 5709ada02..d42742b84 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -24,18 +24,22 @@ let rec constant_of_const ~target c : Code.constant = match c with | Const_base (Const_int i) -> Int - ( Regular - , match target with - | `JavaScript -> Int32.of_int_warning_on_overflow i - | `Wasm -> Int31.of_int_warning_on_overflow i ) - | Const_base (Const_char c) -> Int (Regular, Int32.of_int (Char.code c)) + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.of_int_warning_on_overflow i) + | Const_base (Const_char c) -> Int (Int32.of_int (Char.code c)) | ((Const_base (Const_string (s, _))) [@if ocaml_version < (4, 11, 0)]) | ((Const_base (Const_string (s, _, _))) [@if ocaml_version >= (4, 11, 0)]) -> String s | Const_base (Const_float s) -> Float (float_of_string s) - | Const_base (Const_int32 i) -> Int (Int32, i) + | Const_base (Const_int32 i) -> + (match target with + | `JavaScript -> Int i + | `Wasm -> Int32 i) | Const_base (Const_int64 i) -> Int64 i | Const_base (Const_nativeint i) -> - Int (Native, Int32.of_nativeint_warning_on_overflow i) + (match target with + | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `Wasm -> NativeInt i) | Const_immstring s -> String s | Const_float_array sl -> let l = List.map ~f:(fun f -> float_of_string f) sl in diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 1caac8caf..906895a53 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -465,10 +465,16 @@ end = struct else if tag = Obj.custom_tag then match ident_of_custom x with - | Some name when same_ident name ident_32 -> Int (Int32, (Obj.magic x : int32)) + | Some name when same_ident name ident_32 -> + let i : int32 = Obj.magic x in + (match target with + | `JavaScript -> Int i + | `Wasm -> Int32 i) | Some name when same_ident name ident_native -> let i : nativeint = Obj.magic x in - Int (Native, Int32.of_nativeint_warning_on_overflow i) + (match target with + | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `Wasm -> NativeInt i) | Some name when same_ident name ident_64 -> Int64 (Obj.magic x : int64) | Some name -> failwith @@ -486,10 +492,9 @@ end = struct else let i : int = Obj.magic x in Int - ( Regular - , match target with - | `JavaScript -> Int32.of_int_warning_on_overflow i - | `Wasm -> Int31.of_int_warning_on_overflow i ) + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.of_int_warning_on_overflow i) let inlined = function | String _ | NativeString _ -> false @@ -498,9 +503,10 @@ end = struct | Int64 _ -> false | Tuple _ -> false | Int _ -> true + | Int32 _ | NativeInt _ -> false end -let const i = Constant (Int (Regular, i)) +let const i = Constant (Int i) (* Globals *) type globals = @@ -770,7 +776,7 @@ let register_global ~target ?(force = false) g i loc rem = ( Var.fresh () , Prim ( Extern "caml_register_global" - , Pc (Int (Regular, Int32.of_int i)) :: Pv (access_global g i) :: args ) ) + , Pc (Int (Int32.of_int i)) :: Pv (access_global g i) :: args ) ) , loc ) :: rem else rem @@ -1522,7 +1528,7 @@ and compile infos pc state instrs = ( x , Prim ( Extern "caml_floatarray_unsafe_get" - , [ Pv y; Pc (Int (Regular, Int32.of_int n)) ] ) ) + , [ Pv y; Pc (Int (Int32.of_int n)) ] ) ) , loc ) :: instrs) | SETFIELD0 -> @@ -1602,7 +1608,7 @@ and compile infos pc state instrs = ( x , Prim ( Extern "caml_floatarray_unsafe_set" - , [ Pv y; Pc (Int (Regular, Int32.of_int n)); Pv z ] ) ) + , [ Pv y; Pc (Int (Int32.of_int n)); Pv z ] ) ) , loc ) :: instrs) | VECTLENGTH -> @@ -2236,7 +2242,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Eq, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Eq, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) , state ) | BNEQ -> @@ -2246,7 +2252,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Eq, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Eq, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) , state ) | BLTINT -> @@ -2256,7 +2262,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Lt, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Lt, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) , state ) | BLEINT -> @@ -2266,7 +2272,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Le, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Le, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) , state ) | BGTINT -> @@ -2276,7 +2282,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Le, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Le, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) , state ) | BGEINT -> @@ -2286,7 +2292,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Lt, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Lt, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) , state ) | BULTINT -> @@ -2296,7 +2302,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Ult, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Ult, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) , state ) | BUGEINT -> @@ -2306,7 +2312,7 @@ and compile infos pc state instrs = let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Ult, [ Pc (Int (Regular, n)); Pv x ])), loc) :: instrs + ( (Let (y, Prim (Ult, [ Pc (Int n); Pv x ])), loc) :: instrs , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) , state ) | ULTINT -> @@ -2369,7 +2375,7 @@ and compile infos pc state instrs = ( m , Prim ( Extern "caml_get_public_method" - , [ Pv obj; Pv tag; Pc (Int (Regular, Int32.of_int cache)) ] ) ) + , [ Pv obj; Pv tag; Pc (Int (Int32.of_int cache)) ] ) ) , loc ) :: (Let (tag, const n), loc) :: instrs) @@ -2396,7 +2402,7 @@ and compile infos pc state instrs = ( m , Prim ( Extern "caml_get_public_method" - , [ Pv obj; Pv tag; Pc (Int (Regular, 0l)) ] ) ) + , [ Pv obj; Pv tag; Pc (Int 0l) ] ) ) , loc ) :: instrs) | GETMETHOD -> @@ -2728,7 +2734,7 @@ let from_exe let need_gdata = ref false in let infos = [ "toc", Constants.parse ~target (Obj.repr toc) - ; "prim_count", Int (Regular, Int32.of_int (Array.length globals.primitives)) + ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in let body = @@ -3110,17 +3116,16 @@ let predefined_exceptions ~target = ( v_index , Constant (Int - ( (* Predefined exceptions are registered in - Symtable.init with [-index - 1] *) - Regular - , Int32.of_int (-index - 1) )) ) + ((* Predefined exceptions are registered in + Symtable.init with [-index - 1] *) + Int32.of_int (-index - 1) ))) , noloc ) ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc ; ( Let ( Var.fresh () , Prim ( Extern "caml_register_global" - , [ Pc (Int (Regular, Int32.of_int index)) + , [ Pc (Int (Int32.of_int index)) ; Pv exn ; Pv (match target with @@ -3177,7 +3182,7 @@ let link_info ~target ~symtable ~primitives ~crcs = in let infos = [ "toc", Constants.parse ~target (Obj.repr toc) - ; "prim_count", Int (Regular, Int32.of_int (List.length primitives)) + ; "prim_count", Int (Int32.of_int (List.length primitives)) ] in let body = diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index d3a376bee..314086521 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -51,7 +51,7 @@ let specialize_instr ~target info i = match the_string_of 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 (Regular, 0l))) + | Some _ -> Let (x, Constant (Int 0l)) | None -> i) | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> ( match the_def_of info a with @@ -284,7 +284,7 @@ let f_once p = , [ _; _; _ ] ) as p) ) -> let x' = Code.Var.fork x in let acc = - (Let (x', p), loc) :: (Let (x, Constant (Int (Regular, 0l))), loc) :: acc + (Let (x', p), loc) :: (Let (x, Constant (Int 0l)), loc) :: acc in loop acc r | _ -> loop ((i, loc) :: acc) r) diff --git a/compiler/lib/wasm/wa_core_target.ml b/compiler/lib/wasm/wa_core_target.ml index ed4079d0e..0e7eafda2 100644 --- a/compiler/lib/wasm/wa_core_target.ml +++ b/compiler/lib/wasm/wa_core_target.ml @@ -348,7 +348,7 @@ end module Constant = struct let rec translate_rec context c = match c with - | Code.Int (Regular, i) -> W.DataI32 Int32.(add (add i i) 1l) + | Code.Int i -> W.DataI32 Int32.(add (add i i) 1l) | Tuple (tag, a, _) -> let h = Memory.header ~const:true ~tag ~len:(Array.length a) () in let name = Code.Var.fresh_n "block" in @@ -397,7 +397,7 @@ module Constant = struct in context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; W.DataSym (V name, 4) - | Int (Int32, i) -> + | Int32 i -> let h = Memory.header ~const:true ~tag:Obj.custom_tag ~len:2 () in let name = Code.Var.fresh_n "int32" in let block = @@ -405,13 +405,13 @@ module Constant = struct in context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; W.DataSym (V name, 4) - | Int (Native, i) -> + | NativeInt i -> let h = Memory.header ~const:true ~tag:Obj.custom_tag ~len:2 () in let name = Code.Var.fresh_n "nativeint" in let block = [ W.DataI32 h ; DataI32 0l (*ZZZ DataSym (S "caml_nativeint_ops", 0)*) - ; DataI32 i + ; DataI32 (Int32.of_nativeint_warning_on_overflow i) ] in context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; diff --git a/compiler/lib/wasm/wa_gc_target.ml b/compiler/lib/wasm/wa_gc_target.ml index 5b7b95480..9f452b668 100644 --- a/compiler/lib/wasm/wa_gc_target.ml +++ b/compiler/lib/wasm/wa_gc_target.ml @@ -933,7 +933,7 @@ module Constant = struct let rec translate_rec c = match c with - | Code.Int (Regular, i) -> return (Const, W.RefI31 (Const (I32 i))) + | Code.Int i -> return (Const, W.RefI31 (Const (I32 i))) | Tuple (tag, a, _) -> let* ty = Type.block_type in let* l = @@ -1031,11 +1031,15 @@ module Constant = struct | Int64 i -> let* e = Memory.make_int64 (return (W.Const (I64 i))) in return (Const, e) - | Int (Int32, i) -> + | Int32 i -> let* e = Memory.make_int32 ~kind:`Int32 (return (W.Const (I32 i))) in return (Const, e) - | Int (Native, i) -> - let* e = Memory.make_int32 ~kind:`Nativeint (return (W.Const (I32 i))) in + | NativeInt i -> + let* e = + Memory.make_int32 + ~kind:`Nativeint + (return (W.Const (I32 (Int32.of_nativeint_warning_on_overflow i)))) + in return (Const, e) let translate c = diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml index 7dcc3ca6d..62c8d80ee 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -166,9 +166,9 @@ module Generate (Target : Wa_target_sig.S) = struct ~cps:(Var.Set.mem x ctx.in_cps) x | Constant c -> Constant.translate c - | Special Undefined -> Constant.translate (Int (Regular, 0l)) + | Special Undefined -> Constant.translate (Int 0l) | Special (Alias_prim _) -> assert false - | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int (_, arity)) ]) + | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) when Poly.(target = `GC) -> Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Int32.to_int arity) | Prim (Extern "caml_alloc_dummy_infix", _) when Poly.(target = `GC) -> From 2034c1932df6dabbf8ed38d8dd5d85e7c0ed2694 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 28 Aug 2024 15:23:29 +0200 Subject: [PATCH 2/5] Distinguish float field accesses in the Code IR --- compiler/lib/code.ml | 20 +++++++++---- compiler/lib/code.mli | 8 +++-- compiler/lib/deadcode.ml | 6 ++-- compiler/lib/eval.ml | 11 +++---- compiler/lib/flow.ml | 10 +++---- compiler/lib/freevars.ml | 4 +-- compiler/lib/generate.ml | 4 +-- compiler/lib/global_flow.ml | 8 ++--- compiler/lib/parse_bytecode.ml | 54 +++++++++++++--------------------- compiler/lib/phisimpl.ml | 2 +- compiler/lib/subst.ml | 4 +-- 11 files changed, 65 insertions(+), 66 deletions(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index b7143e3f2..591cac4c1 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -377,6 +377,10 @@ type mutability = | Immutable | Maybe_mutable +type field_type = + | Non_float + | Float + type expr = | Apply of { f : Var.t @@ -384,7 +388,7 @@ type expr = ; exact : bool } | Block of int * Var.t array * array_or_not * mutability - | Field of Var.t * int + | Field of Var.t * int * field_type | Closure of Var.t list * cont | Constant of constant | Prim of prim * prim_arg list @@ -393,7 +397,7 @@ type expr = type instr = | Let of Var.t * expr | Assign of Var.t * Var.t - | Set_field of Var.t * int * Var.t + | Set_field of Var.t * int * field_type * Var.t | Offset_ref of Var.t * int | Array_set of Var.t * Var.t * Var.t @@ -537,7 +541,8 @@ module Print = struct Format.fprintf f "; %d = %a" i Var.print a.(i) done; Format.fprintf f "}" - | Field (x, i) -> Format.fprintf f "%a[%d]" Var.print x i + | Field (x, i, Non_float) -> Format.fprintf f "%a[%d]" Var.print x i + | Field (x, i, Float) -> Format.fprintf f "FLOAT{%a[%d]}" Var.print x i | Closure (l, c) -> Format.fprintf f "fun(%a){%a}" var_list l cont c | Constant c -> Format.fprintf f "CONST{%a}" constant c | Prim (p, l) -> prim f p l @@ -547,7 +552,10 @@ module Print = struct match i with | Let (x, e) -> Format.fprintf f "%a = %a" Var.print x expr e | Assign (x, y) -> Format.fprintf f "(assign) %a = %a" Var.print x Var.print y - | Set_field (x, i, y) -> Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y + | Set_field (x, i, Non_float, y) -> + Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y + | Set_field (x, i, Float, y) -> + Format.fprintf f "FLOAT{%a[%d]} = %a" Var.print x i Var.print y | Offset_ref (x, i) -> Format.fprintf f "%a[0] += %d" Var.print x i | Array_set (x, y, z) -> Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z @@ -821,7 +829,7 @@ let invariant { blocks; start; _ } = let check_expr = function | Apply _ -> () | Block (_, _, _, _) -> () - | Field (_, _) -> () + | Field (_, _, _) -> () | Closure (l, cont) -> List.iter l ~f:define; check_cont cont @@ -835,7 +843,7 @@ let invariant { blocks; start; _ } = define x; check_expr e | Assign _ -> () - | Set_field (_, _i, _) -> () + | Set_field (_, _i, _, _) -> () | Offset_ref (_x, _i) -> () | Array_set (_x, _y, _z) -> () in diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 16af48737..6e8f0d0bd 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -191,6 +191,10 @@ type mutability = | Immutable | Maybe_mutable +type field_type = + | Non_float + | Float + type expr = | Apply of { f : Var.t @@ -198,7 +202,7 @@ type expr = ; exact : bool (* if true, then # of arguments = # of parameters *) } | Block of int * Var.t array * array_or_not * mutability - | Field of Var.t * int + | Field of Var.t * int * field_type | Closure of Var.t list * cont | Constant of constant | Prim of prim * prim_arg list @@ -207,7 +211,7 @@ type expr = type instr = | Let of Var.t * expr | Assign of Var.t * Var.t - | Set_field of Var.t * int * Var.t + | Set_field of Var.t * int * field_type * Var.t | Offset_ref of Var.t * int | Array_set of Var.t * Var.t * Var.t diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml index ae182423f..5e7b61756 100644 --- a/compiler/lib/deadcode.ml +++ b/compiler/lib/deadcode.ml @@ -62,7 +62,7 @@ and mark_expr st e = mark_var st f; List.iter args ~f:(fun x -> mark_var st x) | Block (_, a, _, _) -> Array.iter a ~f:(fun x -> mark_var st x) - | Field (x, _) -> mark_var st x + | Field (x, _, _) -> mark_var st x | Closure (_, (pc, _)) -> mark_reachable st pc | Special _ -> () | Prim (_, l) -> @@ -82,7 +82,7 @@ and mark_reachable st pc = match i with | Let (_, e) -> if not (pure_expr st.pure_funs e) then mark_expr st e | Assign _ -> () - | Set_field (x, _, y) -> + | Set_field (x, _, _, y) -> mark_var st x; mark_var st y | Array_set (x, y, z) -> @@ -190,7 +190,7 @@ let f ({ blocks; _ } as p : Code.program) = match i with | Let (x, e) -> add_def defs x (Expr e) | Assign (x, y) -> add_def defs x (Var y) - | Set_field (_, _, _) | Array_set (_, _, _) | Offset_ref (_, _) -> ()); + | Set_field (_, _, _, _) | Array_set (_, _, _) | Offset_ref (_, _) -> ()); match fst block.branch with | Return _ | Raise _ | Stop -> () | Branch cont -> add_cont_dep blocks defs cont diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index e61bd48a5..d8a4e48e2 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -42,7 +42,7 @@ let shift l w t f = Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) | _ -> None -let float_binop_aux l f = +let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option = let args = match l with | [ Float i; Float j ] -> Some (i, j) @@ -55,12 +55,12 @@ let float_binop_aux l f = | None -> None | Some (i, j) -> Some (f i j) -let float_binop l f = +let float_binop (l : constant list) (f : float -> float -> float) : constant option = match float_binop_aux l f with | Some x -> Some (Float x) | None -> None -let float_unop l f = +let float_unop (l : constant list) (f : float -> float) : constant option = match l with | [ Float i ] -> Some (Float (f i)) | [ Int i ] -> Some (Float (f (Int32.to_float i))) @@ -426,10 +426,11 @@ let rec do_not_raise pc visited blocks = let b = Addr.Map.find pc blocks in List.iter b.body ~f:(fun (i, _loc) -> match i with - | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _) | Assign _ -> () + | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _, _) | Assign _ -> + () | Let (_, e) -> ( match e with - | Block (_, _, _, _) | Field (_, _) | Constant _ | Closure _ -> () + | Block (_, _, _, _) | Field (_, _, _) | Constant _ | Closure _ -> () | Apply _ -> raise May_raise | Special _ -> () | Prim (Extern name, _) when Primitive.is_pure name -> () diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index b5ee88b9a..f5e8193ea 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -94,7 +94,7 @@ let expr_deps blocks vars deps defs x e = List.iter l ~f:(fun x -> add_param_def vars defs x); cont_deps blocks vars deps defs cont | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) - | Field (y, _) -> add_dep deps x y + | Field (y, _, _) -> add_dep deps x y let program_deps { blocks; _ } = let nv = Var.count () in @@ -138,7 +138,7 @@ let propagate1 deps defs st x = match e with | Constant _ | Apply _ | Prim _ | Special _ | Closure _ | Block _ -> Var.Set.singleton x - | Field (y, n) -> + | Field (y, n, _) -> var_set_lift (fun z -> match defs.(Var.idx z) with @@ -244,7 +244,7 @@ let program_escape defs known_origins { blocks; _ } = match i with | Let (x, e) -> expr_escape st x e | Assign _ -> () - | Set_field (x, _, y) | Array_set (x, _, y) -> + | Set_field (x, _, _, y) | Array_set (x, _, y) -> Var.Set.iter (fun y -> Var.ISet.add possibly_mutable y) (Var.Tbl.get known_origins x); @@ -268,7 +268,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x = | Expr e -> ( match e with | Constant _ | Closure _ | Apply _ | Prim _ | Block _ | Special _ -> false - | Field (y, n) -> + | Field (y, n, _) -> Var.Tbl.get st y || Var.Set.exists (fun z -> @@ -360,7 +360,7 @@ let the_native_string_of info x = (*XXX Maybe we could iterate? *) let direct_approx info x = match info.info_defs.(Var.idx x) with - | Expr (Field (y, n)) -> + | Expr (Field (y, n, _)) -> get_approx info (fun z -> diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml index fdeaa8321..b0601ccba 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -34,7 +34,7 @@ let iter_expr_free_vars f e = f x; List.iter ~f args | Block (_, a, _, _) -> Array.iter ~f a - | Field (x, _) -> f x + | Field (x, _, _) -> f x | Closure _ -> () | Special _ -> () | Prim (_, l) -> @@ -46,7 +46,7 @@ let iter_expr_free_vars f e = let iter_instr_free_vars f i = match i with | Let (_, e) -> iter_expr_free_vars f e - | Set_field (x, _, y) -> + | Set_field (x, _, _, y) -> f x; f y | Offset_ref (x, _) -> f x diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 5dcf214e4..58893caae 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1240,7 +1240,7 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list = | NotArray | Unknown -> Mlvalue.Block.make ~tag ~args:contents in (x, prop, queue), [] - | Field (x, n) -> + | Field (x, n, _) -> let (px, cx), queue = access_queue queue x in (Mlvalue.Block.field cx n, or_p px mutable_p, queue), [] | Closure (args, ((pc, _) as cont)) -> @@ -1532,7 +1532,7 @@ and translate_instr ctx expr_queue instr = expr_queue prop (instrs @ [ J.variable_declaration [ J.V x, (ce, loc) ], loc ])) - | Set_field (x, n, y) -> + | Set_field (x, n, _, y) -> let loc = source_location_ctx ctx pc in let (_px, cx), expr_queue = access_queue expr_queue x in let (_py, cy), expr_queue = access_queue expr_queue y in diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 26b4f45d3..12c5caaee 100644 --- a/compiler/lib/global_flow.ml +++ b/compiler/lib/global_flow.ml @@ -230,7 +230,7 @@ let expr_deps blocks st x e = | Closure (l, cont) -> List.iter l ~f:(fun x -> add_param_def st x); cont_deps blocks st cont - | Field (y, _) -> add_dep st x y + | Field (y, _, _) -> add_dep st x y let program_deps st { blocks; _ } = Addr.Map.iter @@ -241,7 +241,7 @@ let program_deps st { blocks; _ } = add_expr_def st x e; expr_deps blocks st x e | Assign (x, y) -> add_assign_def st x y - | Set_field (x, _, y) | Array_set (x, _, y) -> + | Set_field (x, _, _, y) | Array_set (x, _, y) -> possibly_mutable st x; do_escape st Escape y | Offset_ref _ -> ()); @@ -274,7 +274,7 @@ let program_deps st { blocks; _ } = List.iter ~f:(fun (i, _) -> match i with - | Let (y, Field (x', _)) when Var.equal b x' -> + | Let (y, Field (x', _, _)) when Var.equal b x' -> Hashtbl.add st.known_cases y tags | _ -> ()) block.body) @@ -401,7 +401,7 @@ let propagate st ~update approx x = (* A constant cannot contain a function *) Domain.bot | Closure _ | Block _ -> Domain.singleton x - | Field (y, n) -> ( + | Field (y, n, _) -> ( match Var.Tbl.get approx y with | Values { known; others } -> let tags = diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 906895a53..9f5c4fa43 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -1313,7 +1313,7 @@ and compile infos pc state instrs = let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; - compile infos (pc + 3) state ((Let (y, Field (x, j)), loc) :: instrs) + compile infos (pc + 3) state ((Let (y, Field (x, j, Non_float)), loc) :: instrs) | PUSHGETGLOBALFIELD -> let state = State.push state loc in @@ -1322,7 +1322,7 @@ and compile infos pc state instrs = let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; - compile infos (pc + 3) state ((Let (y, Field (x, j)), loc) :: instrs) + compile infos (pc + 3) state ((Let (y, Field (x, j, Non_float)), loc) :: instrs) | SETGLOBAL -> let i = getu code (pc + 1) in State.size_globals state (i + 1); @@ -1488,49 +1488,40 @@ and compile infos pc state instrs = let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[0]@." Var.print x Var.print y; - compile infos (pc + 1) state ((Let (x, Field (y, 0)), loc) :: instrs) + compile infos (pc + 1) state ((Let (x, Field (y, 0, Non_float)), loc) :: instrs) | GETFIELD1 -> let y, _ = State.accu state in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[1]@." Var.print x Var.print y; - compile infos (pc + 1) state ((Let (x, Field (y, 1)), loc) :: instrs) + compile infos (pc + 1) state ((Let (x, Field (y, 1, Non_float)), loc) :: instrs) | GETFIELD2 -> let y, _ = State.accu state in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[2]@." Var.print x Var.print y; - compile infos (pc + 1) state ((Let (x, Field (y, 2)), loc) :: instrs) + compile infos (pc + 1) state ((Let (x, Field (y, 2, Non_float)), loc) :: instrs) | GETFIELD3 -> let y, _ = State.accu state in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[3]@." Var.print x Var.print y; - compile infos (pc + 1) state ((Let (x, Field (y, 3)), loc) :: instrs) + compile infos (pc + 1) state ((Let (x, Field (y, 3, Non_float)), loc) :: instrs) | GETFIELD -> let y, _ = State.accu state in let n = getu code (pc + 1) in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print x Var.print y n; - compile infos (pc + 2) state ((Let (x, Field (y, n)), loc) :: instrs) + compile infos (pc + 2) state ((Let (x, Field (y, n, Non_float)), loc) :: instrs) | GETFLOATFIELD -> let y, _ = State.accu state in let n = getu code (pc + 1) in let x, state = State.fresh_var state loc in - if debug_parser () then Format.printf "%a = %a[%d]@." Var.print x Var.print y n; - compile - infos - (pc + 2) - state - (( Let - ( x - , Prim - ( Extern "caml_floatarray_unsafe_get" - , [ Pv y; Pc (Int (Int32.of_int n)) ] ) ) - , loc ) - :: instrs) + if debug_parser () + then Format.printf "%a = FLOAT{%a[%d]}@." Var.print x Var.print y n; + compile infos (pc + 2) state ((Let (x, Field (y, n, Float)), loc) :: instrs) | SETFIELD0 -> let y, _ = State.accu state in let z, _ = State.peek 0 state in @@ -1542,7 +1533,7 @@ and compile infos pc state instrs = infos (pc + 1) (State.pop 1 state) - ((Let (x, const 0l), loc) :: (Set_field (y, 0, z), loc) :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, 0, Non_float, z), loc) :: instrs) | SETFIELD1 -> let y, _ = State.accu state in let z, _ = State.peek 0 state in @@ -1554,7 +1545,7 @@ and compile infos pc state instrs = infos (pc + 1) (State.pop 1 state) - ((Let (x, const 0l), loc) :: (Set_field (y, 1, z), loc) :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, 1, Non_float, z), loc) :: instrs) | SETFIELD2 -> let y, _ = State.accu state in let z, _ = State.peek 0 state in @@ -1566,7 +1557,7 @@ and compile infos pc state instrs = infos (pc + 1) (State.pop 1 state) - ((Let (x, const 0l), loc) :: (Set_field (y, 2, z), loc) :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, 2, Non_float, z), loc) :: instrs) | SETFIELD3 -> let y, _ = State.accu state in let z, _ = State.peek 0 state in @@ -1578,7 +1569,7 @@ and compile infos pc state instrs = infos (pc + 1) (State.pop 1 state) - ((Let (x, const 0l), loc) :: (Set_field (y, 3, z), loc) :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, 3, Non_float, z), loc) :: instrs) | SETFIELD -> let y, _ = State.accu state in let z, _ = State.peek 0 state in @@ -1591,26 +1582,21 @@ and compile infos pc state instrs = infos (pc + 2) (State.pop 1 state) - ((Let (x, const 0l), loc) :: (Set_field (y, n, z), loc) :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, n, Non_float, z), loc) :: instrs) | SETFLOATFIELD -> let y, _ = State.accu state in let z, _ = State.peek 0 state in let n = getu code (pc + 1) in - if debug_parser () then Format.printf "%a[%d] = %a@." Var.print y n Var.print z; + if debug_parser () + then Format.printf "FLOAT{%a[%d]} = %a@." Var.print y n Var.print z; let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = 0@." Var.print x; compile infos (pc + 2) (State.pop 1 state) - (( Let - ( x - , Prim - ( Extern "caml_floatarray_unsafe_set" - , [ Pv y; Pc (Int (Int32.of_int n)); Pv z ] ) ) - , loc ) - :: instrs) + ((Let (x, const 0l), loc) :: (Set_field (y, n, Float, z), loc) :: instrs) | VECTLENGTH -> let y, _ = State.accu state in let x, state = State.fresh_var state loc in @@ -2418,7 +2404,7 @@ and compile infos pc state instrs = (pc + 1) state ((Let (m, Prim (Array_get, [ Pv meths; Pv lab ])), loc) - :: (Let (meths, Field (obj, 0)), loc) + :: (Let (meths, Field (obj, 0, Non_float)), loc) :: instrs) | STOP -> instrs, (Stop, loc), state | RESUME -> @@ -2847,7 +2833,7 @@ let from_bytes ~prims ~debug (code : bytecode) = | None -> () | Some name -> Code.Var.name x name); need_gdata := true; - (Let (x, Field (gdata, i)), noloc) :: l + (Let (x, Field (gdata, i, Non_float)), noloc) :: l | _ -> l) in let body = diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index 159c8570a..88e541e69 100644 --- a/compiler/lib/phisimpl.ml +++ b/compiler/lib/phisimpl.ml @@ -53,7 +53,7 @@ let expr_deps blocks vars deps defs x e = | Constant _ | Apply _ | Prim _ | Special _ -> () | Closure (_, cont) -> cont_deps blocks vars deps defs cont | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y) - | Field (y, _) -> add_dep deps x y + | Field (y, _, _) -> add_dep deps x y let program_deps { blocks; _ } = let nv = Var.count () in diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 4e735576c..bd1e41f41 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -29,7 +29,7 @@ let expr s e = | Apply { f; args; exact } -> Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) - | Field (x, n) -> Field (s x, n) + | Field (x, n, typ) -> Field (s x, n, typ) | Closure (l, pc) -> Closure (l, subst_cont s pc) | Special _ -> e | Prim (p, l) -> @@ -44,7 +44,7 @@ let instr s i = match i with | Let (x, e) -> Let (x, expr s e) | Assign (x, y) -> Assign (x, s y) (* x is handled like a parameter *) - | Set_field (x, n, y) -> Set_field (s x, n, s y) + | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) | Offset_ref (x, n) -> Offset_ref (s x, n) | Array_set (x, y, z) -> Array_set (s x, s y, s z) From 1a24255e67b9a847f0128735fcd75c2c528d8207 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Sep 2024 15:33:49 +0200 Subject: [PATCH 3/5] WSOO side of "Distinguish float field accesses in the Code IR" See ocsigen/js_of_ocaml#1649 --- compiler/lib/wasm/wa_generate.ml | 17 +++++++++++++++-- compiler/lib/wasm/wa_globalize.ml | 4 ++-- compiler/lib/wasm/wa_liveness.ml | 4 ++-- compiler/lib/wasm/wa_spilling.ml | 4 ++-- 4 files changed, 21 insertions(+), 8 deletions(-) diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml index 62c8d80ee..9eedaa7e9 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -157,7 +157,11 @@ module Generate (Target : Wa_target_sig.S) = struct return (W.Call (apply, args @ [ closure ])) | Block (tag, a, _, _) -> Memory.allocate stack_ctx x ~tag (List.map ~f:(fun x -> `Var x) (Array.to_list a)) - | Field (x, n) -> Memory.field (load x) n + | Field (x, n, Non_float) -> Memory.field (load x) n + | Field (x, n, Float) -> + Memory.float_array_get + (load x) + (Constant.translate (Int (Int31.of_int_warning_on_overflow n))) | Closure _ -> Closure.translate ~context:ctx.global_context @@ -668,7 +672,16 @@ module Generate (Target : Wa_target_sig.S) = struct if ctx.live.(Var.idx x) = 0 then drop (translate_expr ctx stack_ctx context x e) else store x (translate_expr ctx stack_ctx context x e) - | Set_field (x, n, y) -> Memory.set_field (load x) n (load y) + | Set_field (x, n, Non_float, y) -> + Memory.set_field + (load x) + n + (load y) + | Set_field (x, n, Float, y) -> + Memory.float_array_set + (load x) + (Constant.translate (Int (Int31.of_int_warning_on_overflow n))) + (load y) | Offset_ref (x, n) -> Memory.set_field (load x) diff --git a/compiler/lib/wasm/wa_globalize.ml b/compiler/lib/wasm/wa_globalize.ml index deaed96b3..5c2cc2d47 100644 --- a/compiler/lib/wasm/wa_globalize.ml +++ b/compiler/lib/wasm/wa_globalize.ml @@ -74,7 +74,7 @@ let traverse_expression x e st = | Code.Apply { f; args; _ } -> st |> use f |> fun st -> List.fold_left ~f:(fun st x -> use x st) ~init:st args | Block (_, a, _, _) -> Array.fold_right ~f:use a ~init:st - | Field (x, _) -> st |> use x + | Field (x, _, _) -> st |> use x | Closure _ -> List.fold_left ~f:(fun st x -> use x st) @@ -95,7 +95,7 @@ let traverse_instruction st i = match fst i with | Code.Let (x, e) -> st |> declare x |> traverse_expression x e | Assign (_, x) | Offset_ref (x, _) -> st |> use x - | Set_field (x, _, y) -> st |> use x |> use y + | Set_field (x, _, _, y) -> st |> use x |> use y | Array_set (x, y, z) -> st |> use x |> use y |> use z let traverse_block p st pc = diff --git a/compiler/lib/wasm/wa_liveness.ml b/compiler/lib/wasm/wa_liveness.ml index 4a2dd9084..59c528411 100644 --- a/compiler/lib/wasm/wa_liveness.ml +++ b/compiler/lib/wasm/wa_liveness.ml @@ -109,12 +109,12 @@ let expr_used ~context ~closures ~ctx x e s = | Prim (_, l) -> add_prim_args ~ctx s l | Closure _ -> add_list ~ctx s (function_free_variables ~context ~closures x) | Constant _ | Special _ -> s - | Field (x, _) -> add_var ~ctx s x + | Field (x, _, _) -> add_var ~ctx s x let propagate_through_instr ~context ~closures ~ctx (i, _) s = match i with | Let (x, e) -> expr_used ~context ~closures ~ctx x e (Var.Set.remove x s) - | Set_field (x, _, y) -> add_var ~ctx (add_var ~ctx s x) y + | Set_field (x, _, _, y) -> add_var ~ctx (add_var ~ctx s x) y | Assign (_, x) | Offset_ref (x, _) -> add_var ~ctx s x | Array_set (x, y, z) -> add_var ~ctx (add_var ~ctx (add_var ~ctx s x) y) z diff --git a/compiler/lib/wasm/wa_spilling.ml b/compiler/lib/wasm/wa_spilling.ml index 2d1051c7b..f1eaa1b80 100644 --- a/compiler/lib/wasm/wa_spilling.ml +++ b/compiler/lib/wasm/wa_spilling.ml @@ -309,10 +309,10 @@ let spilled_variables fv ~init:Var.Set.empty | Constant _ | Special _ -> Var.Set.empty - | Field (x, _) -> check_spilled ~ctx loaded x Var.Set.empty) + | Field (x, _, _) -> check_spilled ~ctx loaded x Var.Set.empty) | Assign (_, x) | Offset_ref (x, _) -> check_spilled ~ctx loaded x Var.Set.empty - | Set_field (x, _, y) -> + | Set_field (x, _, _, y) -> Var.Set.empty |> check_spilled ~ctx loaded x |> check_spilled ~ctx loaded y From 989a1d6c57e546617b84946d53820eb26cccf77b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Sep 2024 15:11:30 +0200 Subject: [PATCH 4/5] Fix build --- compiler/lib/eval.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index d8a4e48e2..21b1041dc 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -351,7 +351,7 @@ let eval_instr ~target info ((x, loc) as i) = , Prim ( prim , List.map2 prim_args prim_args' ~f:(fun arg c -> - match c, target with + match (c : constant), target with | Some ((Int _ | NativeString _) as c), _ -> Pc c | Some (Float _ as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript From d7de3b6702a6d5029d23407b26679ea2114f97e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 20 Sep 2024 10:40:52 +0200 Subject: [PATCH 5/5] Fixes --- compiler/lib/eval.ml | 15 +++++++-------- compiler/lib/generate_closure.ml | 15 +++++---------- compiler/lib/inline.ml | 2 +- 3 files changed, 13 insertions(+), 19 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 21b1041dc..77eb5e332 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -38,8 +38,7 @@ let int_binop l w f = let shift l w t f = match l with - | [ Int i; Int j ] -> - Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) + | [ Int i; Int j ] -> Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) | _ -> None let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option = @@ -159,8 +158,8 @@ let eval_prim ~target x = Some (Int (match target with - | `JavaScript -> 32l - | `Wasm -> 31l )) + | `JavaScript -> 32l + | `Wasm -> 31l)) | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int 0l) | _ -> None) @@ -351,7 +350,7 @@ let eval_instr ~target info ((x, loc) as i) = , Prim ( prim , List.map2 prim_args prim_args' ~f:(fun arg c -> - match (c : constant), target with + match (c : constant option), target with | Some ((Int _ | NativeString _) as c), _ -> Pc c | Some (Float _ as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript @@ -373,9 +372,9 @@ let the_cond_of info x = get_approx info (fun x -> - match Flow.Info.def info x with - | Some (Constant (Int 0l)) -> Zero - | Some + match info.info_defs.(Var.idx x) with + | Expr (Constant (Int 0l)) -> Zero + | Expr (Constant ( Int _ | Int32 _ diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index 3094ac98c..87f5d0cfe 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -105,9 +105,7 @@ module Trampoline = struct let counter_plus_1 = Code.Var.fork counter in { params = [] ; body = - [ ( Let - ( counter_plus_1 - , Prim (Extern "%int_add", [ Pv counter; Pc (Int 1l) ]) ) + [ ( Let (counter_plus_1, Prim (Extern "%int_add", [ Pv counter; Pc (Int 1l) ])) , noloc ) ; Let (return, Apply { f; args = counter_plus_1 :: args; exact = true }), loc ] @@ -121,9 +119,8 @@ module Trampoline = struct ; body = [ ( Let ( new_args - , Prim - ( Extern "%js_array" - , Pc (Int 0l) :: List.map args ~f:(fun x -> Pv x) ) ) + , Prim (Extern "%js_array", Pc (Int 0l) :: List.map args ~f:(fun x -> Pv x)) + ) , noloc ) ; Let (return, Prim (Extern "caml_trampoline_return", [ Pv f; Pv new_args ])), loc ] @@ -246,9 +243,7 @@ module Trampoline = struct , Prim ( Lt , [ Pv counter - ; Pc - (Int - (Int32.of_int tailcall_max_depth)) + ; Pc (Int (Int32.of_int tailcall_max_depth)) ] ) ) , noloc ) in @@ -388,7 +383,7 @@ let rewrite_mutable ] @ List.mapi closures_extern ~f:(fun i x -> match x with - | Let (x, Closure _), loc -> Let (x, Field (closure', i)), loc + | Let (x, Closure _), loc -> Let (x, Field (closure', i, Non_float)), loc | _ -> assert false) in free_pc, blocks, body diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 40cebb0ad..16b9ae535 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -170,7 +170,7 @@ let simple blocks cont mapping = | Special _ -> `Exp exp | Block (tag, args, aon, mut) -> `Exp (Block (tag, Array.map args ~f:(map_var mapping), aon, mut)) - | Field (x, i) -> `Exp (Field (map_var mapping x, i)) + | Field (x, i, kind) -> `Exp (Field (map_var mapping x, i, kind)) | Closure _ -> `Fail | Constant _ -> `Fail | Apply _ -> `Fail)