Compiler: add a warning when we redefine the purity of a primitive

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

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 ()

compiler/lib/generate.mli

@@ -25,3 +25,5 @@ val f :
   -> should_export:bool
   -> Parse_bytecode.Debug.t
   -> Javascript.program
+
+val init : unit -> unit

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

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

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