From 23a155259de30b054289392c3f01218e140ceee7 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] 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 26054b1f0..a332d9b8c 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 2037cd59c..6b6ea53f1 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 4c0d714a1..b076f10a7 100644 --- a/compiler/lib/wasm/wa_gc_target.ml +++ b/compiler/lib/wasm/wa_gc_target.ml @@ -935,7 +935,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 = @@ -1033,11 +1033,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 74197663c..87a18b578 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -165,9 +165,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) ->