From 280cd6cbb34972d6115d4ffb58ff9dcd952c3c8a Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Thu, 13 Oct 2022 11:25:17 +0200 Subject: [PATCH 1/2] Compiler: sync primitives info --- compiler/lib/generate.ml | 158 +++++++++++++++++++------------------ compiler/lib/generate.mli | 2 + compiler/lib/linker.ml | 4 +- compiler/lib/primitive.ml | 23 +++++- compiler/lib/primitive.mli | 4 +- 5 files changed, 110 insertions(+), 81 deletions(-) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 0d625f06dc..6750772f8c 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -748,83 +748,15 @@ let apply_fun ctx f params loc = (****) -let _ = - List.iter - ~f:(fun (nm, nm') -> Primitive.alias nm nm') - [ "%int_mul", "caml_mul" - ; "%int_div", "caml_div" - ; "%int_mod", "caml_mod" - ; "caml_int32_neg", "%int_neg" - ; "caml_int32_add", "%int_add" - ; "caml_int32_sub", "%int_sub" - ; "caml_int32_mul", "%int_mul" - ; "caml_int32_div", "%int_div" - ; "caml_int32_mod", "%int_mod" - ; "caml_int32_and", "%int_and" - ; "caml_int32_or", "%int_or" - ; "caml_int32_xor", "%int_xor" - ; "caml_int32_shift_left", "%int_lsl" - ; "caml_int32_shift_right", "%int_asr" - ; "caml_int32_shift_right_unsigned", "%int_lsr" - ; "caml_int32_of_int", "%identity" - ; "caml_int32_to_int", "%identity" - ; "caml_int32_of_float", "caml_int_of_float" - ; "caml_int32_to_float", "%identity" - ; "caml_int32_format", "caml_format_int" - ; "caml_int32_of_string", "caml_int_of_string" - ; "caml_int32_compare", "caml_int_compare" - ; "caml_nativeint_neg", "%int_neg" - ; "caml_nativeint_add", "%int_add" - ; "caml_nativeint_sub", "%int_sub" - ; "caml_nativeint_mul", "%int_mul" - ; "caml_nativeint_div", "%int_div" - ; "caml_nativeint_mod", "%int_mod" - ; "caml_nativeint_and", "%int_and" - ; "caml_nativeint_or", "%int_or" - ; "caml_nativeint_xor", "%int_xor" - ; "caml_nativeint_shift_left", "%int_lsl" - ; "caml_nativeint_shift_right", "%int_asr" - ; "caml_nativeint_shift_right_unsigned", "%int_lsr" - ; "caml_nativeint_of_int", "%identity" - ; "caml_nativeint_to_int", "%identity" - ; "caml_nativeint_of_float", "caml_int_of_float" - ; "caml_nativeint_to_float", "%identity" - ; "caml_nativeint_of_int32", "%identity" - ; "caml_nativeint_to_int32", "%identity" - ; "caml_nativeint_format", "caml_format_int" - ; "caml_nativeint_of_string", "caml_int_of_string" - ; "caml_nativeint_compare", "caml_int_compare" - ; "caml_nativeint_bswap", "caml_int32_bswap" - ; "caml_int64_of_int", "caml_int64_of_int32" - ; "caml_int64_to_int", "caml_int64_to_int32" - ; "caml_int64_of_nativeint", "caml_int64_of_int32" - ; "caml_int64_to_nativeint", "caml_int64_to_int32" - ; "caml_float_of_int", "%identity" - ; "caml_array_get_float", "caml_array_get" - ; "caml_floatarray_get", "caml_array_get" - ; "caml_array_get_addr", "caml_array_get" - ; "caml_array_set_float", "caml_array_set" - ; "caml_floatarray_set", "caml_array_set" - ; "caml_array_set_addr", "caml_array_set" - ; "caml_array_unsafe_get_float", "caml_array_unsafe_get" - ; "caml_floatarray_unsafe_get", "caml_array_unsafe_get" - ; "caml_array_unsafe_set_float", "caml_array_unsafe_set" - ; "caml_floatarray_unsafe_set", "caml_array_unsafe_set" - ; "caml_alloc_dummy_float", "caml_alloc_dummy" - ; "caml_make_array", "%identity" - ; "caml_ensure_stack_capacity", "%identity" - ; "caml_js_from_float", "%identity" - ; "caml_js_to_float", "%identity" - ] - let internal_primitives = Hashtbl.create 31 let internal_prim name = - try Hashtbl.find internal_primitives name with Not_found -> None + try + let _, f = Hashtbl.find internal_primitives name in + Some f + with Not_found -> None -let register_prim name k f = - Primitive.register name k None None; - Hashtbl.add internal_primitives name (Some f) +let register_prim name k f = Hashtbl.add internal_primitives name (k, f) let register_un_prim name k f = register_prim name k (fun l queue ctx loc -> @@ -930,13 +862,13 @@ let _ = register_tern_prim "caml_js_set" (fun cx cy cz _ -> J.EBin (J.Eq, J.EAccess (cx, cy), cz)); register_bin_prim "caml_js_get" `Mutable (fun cx cy _ -> J.EAccess (cx, cy)); - register_bin_prim "caml_js_delete" `Mutable (fun cx cy _ -> + register_bin_prim "caml_js_delete" `Mutator (fun cx cy _ -> J.EUn (J.Delete, J.EAccess (cx, cy))); register_bin_prim "caml_js_equals" `Mutable (fun cx cy _ -> bool (J.EBin (J.EqEq, cx, cy))); - register_bin_prim "caml_js_instanceof" `Pure (fun cx cy _ -> + register_bin_prim "caml_js_instanceof" `Mutator (fun cx cy _ -> bool (J.EBin (J.InstanceOf, cx, cy))); - register_un_prim "caml_js_typeof" `Pure (fun cx _ -> J.EUn (J.Typeof, cx)) + register_un_prim "caml_js_typeof" `Mutator (fun cx _ -> J.EUn (J.Typeof, cx)) (* This is not correct when switching the js-string flag *) (* {[ @@ -1952,3 +1884,77 @@ let f (p : Code.program) ~exported_runtime ~live_vars ~should_export debug = let p = compile_program ctx p.start in if times () then Format.eprintf " code gen.: %a@." Timer.print t'; p + +let init () = + List.iter + ~f:(fun (nm, nm') -> Primitive.alias nm nm') + [ "%int_mul", "caml_mul" + ; "%int_div", "caml_div" + ; "%int_mod", "caml_mod" + ; "caml_int32_neg", "%int_neg" + ; "caml_int32_add", "%int_add" + ; "caml_int32_sub", "%int_sub" + ; "caml_int32_mul", "%int_mul" + ; "caml_int32_div", "%int_div" + ; "caml_int32_mod", "%int_mod" + ; "caml_int32_and", "%int_and" + ; "caml_int32_or", "%int_or" + ; "caml_int32_xor", "%int_xor" + ; "caml_int32_shift_left", "%int_lsl" + ; "caml_int32_shift_right", "%int_asr" + ; "caml_int32_shift_right_unsigned", "%int_lsr" + ; "caml_int32_of_int", "%identity" + ; "caml_int32_to_int", "%identity" + ; "caml_int32_of_float", "caml_int_of_float" + ; "caml_int32_to_float", "%identity" + ; "caml_int32_format", "caml_format_int" + ; "caml_int32_of_string", "caml_int_of_string" + ; "caml_int32_compare", "caml_int_compare" + ; "caml_nativeint_neg", "%int_neg" + ; "caml_nativeint_add", "%int_add" + ; "caml_nativeint_sub", "%int_sub" + ; "caml_nativeint_mul", "%int_mul" + ; "caml_nativeint_div", "%int_div" + ; "caml_nativeint_mod", "%int_mod" + ; "caml_nativeint_and", "%int_and" + ; "caml_nativeint_or", "%int_or" + ; "caml_nativeint_xor", "%int_xor" + ; "caml_nativeint_shift_left", "%int_lsl" + ; "caml_nativeint_shift_right", "%int_asr" + ; "caml_nativeint_shift_right_unsigned", "%int_lsr" + ; "caml_nativeint_of_int", "%identity" + ; "caml_nativeint_to_int", "%identity" + ; "caml_nativeint_of_float", "caml_int_of_float" + ; "caml_nativeint_to_float", "%identity" + ; "caml_nativeint_of_int32", "%identity" + ; "caml_nativeint_to_int32", "%identity" + ; "caml_nativeint_format", "caml_format_int" + ; "caml_nativeint_of_string", "caml_int_of_string" + ; "caml_nativeint_compare", "caml_int_compare" + ; "caml_nativeint_bswap", "caml_int32_bswap" + ; "caml_int64_of_int", "caml_int64_of_int32" + ; "caml_int64_to_int", "caml_int64_to_int32" + ; "caml_int64_of_nativeint", "caml_int64_of_int32" + ; "caml_int64_to_nativeint", "caml_int64_to_int32" + ; "caml_float_of_int", "%identity" + ; "caml_array_get_float", "caml_array_get" + ; "caml_floatarray_get", "caml_array_get" + ; "caml_array_get_addr", "caml_array_get" + ; "caml_array_set_float", "caml_array_set" + ; "caml_floatarray_set", "caml_array_set" + ; "caml_array_set_addr", "caml_array_set" + ; "caml_array_unsafe_get_float", "caml_array_unsafe_get" + ; "caml_floatarray_unsafe_get", "caml_array_unsafe_get" + ; "caml_array_unsafe_set_float", "caml_array_unsafe_set" + ; "caml_floatarray_unsafe_set", "caml_array_unsafe_set" + ; "caml_alloc_dummy_float", "caml_alloc_dummy" + ; "caml_make_array", "%identity" + ; "caml_ensure_stack_capacity", "%identity" + ; "caml_js_from_float", "%identity" + ; "caml_js_to_float", "%identity" + ]; + Hashtbl.iter + (fun name (k, _) -> Primitive.register name k None None) + internal_primitives + +let () = init () diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index 8d719282b9..a4e7e26462 100644 --- a/compiler/lib/generate.mli +++ b/compiler/lib/generate.mli @@ -25,3 +25,5 @@ val f : -> should_export:bool -> Parse_bytecode.Debug.t -> Javascript.program + +val init : unit -> unit diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 652643b759..6fcd1cc8eb 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -379,7 +379,9 @@ let reset () = always_included := []; Hashtbl.clear provided; Hashtbl.clear provided_rev; - Hashtbl.clear code_pieces + Hashtbl.clear code_pieces; + Primitive.reset (); + Generate.init () let load_fragment ~target_env ~filename (f : Fragment.t) = match f with diff --git a/compiler/lib/primitive.ml b/compiler/lib/primitive.ml index 8075c4da9e..55f9e8d27a 100644 --- a/compiler/lib/primitive.ml +++ b/compiler/lib/primitive.ml @@ -53,6 +53,11 @@ type t = | condition ] +let string_of_kind = function + | `Pure -> "pure" + | `Mutable -> "mutable" + | `Mutator -> "mutator" + let kinds = Hashtbl.create 37 let kind_args_tbl = Hashtbl.create 37 @@ -76,11 +81,18 @@ let externals = ref StringSet.empty let add_external name = externals := StringSet.add name !externals -let is_external name = StringSet.mem name !externals - let get_external () = !externals let register p k kargs arity = + (match Hashtbl.find kinds (resolve p) with + | exception Not_found -> () + | k' when Poly.(k = k') -> () + | k' -> + warn + "Warning: overriding the purity of the primitive %s: %s -> %s@." + p + (string_of_kind k') + (string_of_kind k)); add_external p; (match arity with | Some a -> Hashtbl.add arities p a @@ -100,3 +112,10 @@ let named_values = ref StringSet.empty let need_named_value s = StringSet.mem s !named_values let register_named_value s = named_values := StringSet.add s !named_values + +let reset () = + Hashtbl.clear kinds; + Hashtbl.clear kind_args_tbl; + Hashtbl.clear arities; + Hashtbl.clear aliases; + named_values := StringSet.empty diff --git a/compiler/lib/primitive.mli b/compiler/lib/primitive.mli index bca09fa0ad..08888360b9 100644 --- a/compiler/lib/primitive.mli +++ b/compiler/lib/primitive.mli @@ -67,10 +67,10 @@ val resolve : string -> string val add_external : string -> unit -val is_external : string -> bool - val get_external : unit -> StringSet.t val need_named_value : string -> bool val register_named_value : string -> unit + +val reset : unit -> unit From 389a30e48b2c2dce1af41332579f315f60b0f216 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 14 Oct 2022 09:53:01 +0200 Subject: [PATCH 2/2] Changes --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index e132be1dc5..92654ee4a4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,7 @@ ## Features/Changes * Compiler: initial support for OCaml 5 (#1265,#1303) * Compiler: bump magic number to match the 5.0.0~alpha0 release (#1288) +* Compiler: complain when runtime and compiler built-in primitives disagree (#1312) * Misc: switch to cmdliner.1.1.0 * Misc: remove old binaries jsoo_link, jsoo_fs * Misc: remove uchar dep