Merge pull request #2279 from stedolan/deprecate-obj-truncate

Deprecate Obj.truncate.

Changes

@@ -100,8 +100,8 @@ Working version
 
 ### Runtime system:
 
-- #1725: Deprecate Obj.set_tag
-  (Stephen Dolan, review by Gabriel Scherer and Damien Doligez)
+- #1725, #2279: Deprecate Obj.set_tag and Obj.truncate
+  (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy)
 
 * #2240: Constify "identifier" in struct custom_operations
   (Cedric Cellier, review by Xavier Leroy)

bytecomp/translprim.ml

@@ -104,6 +104,9 @@ let get_used_primitives () =
 let gen_array_kind =
   if Config.flat_float_array then Pgenarray else Paddrarray
 
+let prim_sys_argv =
+  Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true
+
 let primitives_table =
   create_hashtable 57 [
     "%identity", Primitive (Pidentity, 1);
@@ -341,6 +344,7 @@ let primitives_table =
     "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1);
     "%int_as_pointer", Primitive (Pint_as_pointer, 1);
     "%opaque", Primitive (Popaque, 1);
+    "%sys_argv", External prim_sys_argv;
     "%send", Send;
     "%sendself", Send_self;
     "%sendcache", Send_cache;
@@ -647,6 +651,8 @@ let lambda_of_prim prim_name prim loc args arg_exps =
   match prim, args with
   | Primitive (prim, arity), args when arity = List.length args ->
       Lprim(prim, args, loc)
+  | External prim, args when prim = prim_sys_argv ->
+      Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc)
   | External prim, args ->
       Lprim(Pccall prim, args, loc)
   | Comparison(comp, knd), ([_;_] as args) ->

runtime/sys.c

@@ -371,22 +371,35 @@ CAMLprim value caml_sys_getenv(value var)
 }
 
 char_os * caml_exe_name;
-char_os ** caml_main_argv;
+static value main_argv;
 
 CAMLprim value caml_sys_get_argv(value unit)
 {
   CAMLparam0 ();   /* unit is unused */
-  CAMLlocal3 (exe_name, argv, res);
+  CAMLlocal2 (exe_name, res);
   exe_name = caml_copy_string_of_os(caml_exe_name);
-  argv =
-    caml_alloc_array((void *)caml_copy_string_of_os,
-                     (char const **) caml_main_argv);
   res = caml_alloc_small(2, 0);
   Field(res, 0) = exe_name;
-  Field(res, 1) = argv;
+  Field(res, 1) = main_argv;
   CAMLreturn(res);
 }
 
+CAMLprim value caml_sys_argv(value unit)
+{
+  return main_argv;
+}
+
+CAMLprim value caml_sys_modify_argv(value new_argv)
+{
+  caml_modify_generational_global_root(&main_argv, new_argv);
+  return Val_unit;
+}
+
+CAMLprim value caml_sys_executable_name(value unit)
+{
+  return caml_copy_string_of_os(caml_exe_name);
+}
+
 void caml_sys_init(char_os * exe_name, char_os **argv)
 {
 #ifdef _WIN32
@@ -398,7 +411,9 @@ void caml_sys_init(char_os * exe_name, char_os **argv)
 #endif
 #endif
   caml_exe_name = exe_name;
-  caml_main_argv = argv;
+  main_argv = caml_alloc_array((void *)caml_copy_string_of_os,
+			       (char const **) argv);
+  caml_register_generational_global_root(&main_argv);
 }
 
 #ifdef _WIN32

stdlib/.depend

@@ -132,11 +132,13 @@ camlinternalLazy.cmx : \
     camlinternalLazy.cmi
 camlinternalLazy.cmi :
 camlinternalMod.cmo : \
+    stdlib__sys.cmi \
     stdlib__obj.cmi \
     camlinternalOO.cmi \
     stdlib__array.cmi \
     camlinternalMod.cmi
 camlinternalMod.cmx : \
+    stdlib__sys.cmx \
     stdlib__obj.cmx \
     camlinternalOO.cmx \
     stdlib__array.cmx \

stdlib/camlinternalMod.ml

@@ -51,8 +51,13 @@ let rec init_mod loc shape =
 let rec update_mod shape o n =
   match shape with
   | Function ->
-      if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
-      then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR#4008 *) end
+      (* The optimisation below is invalid on bytecode since
+         the RESTART instruction checks the length of closures.
+         See PR#4008 *)
+      if Sys.backend_type = Sys.Native
+      && Obj.tag n = Obj.closure_tag
+      && Obj.size n <= Obj.size o
+      then begin overwrite o n end
       else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
   | Lazy ->
       if Obj.tag n = Obj.lazy_tag then

stdlib/obj.mli

@@ -63,6 +63,7 @@ val [@inline always] set_double_field : t -> int -> float -> unit
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
+  [@@ocaml.deprecated]
 external add_offset : t -> Int32.t -> t = "caml_obj_add_offset"
          (* @since 3.12.0 *)
 external with_tag : int -> t -> t = "caml_obj_with_tag"

stdlib/sys.mli

@@ -20,7 +20,7 @@
   an error.
 *)
 
-val argv : string array
+external argv : string array = "%sys_argv"
 (** The command line arguments given to the process.
    The first element is the command name used to invoke the program.
    The following elements are the command-line arguments

stdlib/sys.mlp

@@ -25,7 +25,8 @@ type backend_type =
 (* System interface *)
 
 external get_config: unit -> string * int * bool = "caml_sys_get_config"
-external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external get_executable_name : unit -> string = "caml_sys_executable_name"
+external argv : string array = "%sys_argv"
 external big_endian : unit -> bool = "%big_endian"
 external word_size : unit -> int = "%word_size"
 external int_size : unit -> int = "%int_size"
@@ -35,7 +36,7 @@ external win32 : unit -> bool = "%ostype_win32"
 external cygwin : unit -> bool = "%ostype_cygwin"
 external get_backend_type : unit -> backend_type = "%backend_type"
 
-let (executable_name, argv) = get_argv()
+let executable_name = get_executable_name()
 let (os_type, _, _) = get_config()
 let backend_type = get_backend_type ()
 let big_endian = big_endian ()

stdlib/weak.ml

@@ -200,8 +200,10 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
         t.table.(t.rover) <- emptybucket;
         t.hashes.(t.rover) <- [| |];
       end else begin
-        Obj.truncate (Obj.repr bucket) (prev_len + additional_values);
-        Obj.truncate (Obj.repr hbucket) prev_len;
+        let newbucket = weak_create prev_len in
+        blit bucket 0 newbucket 0 prev_len;
+        t.table.(t.rover) <- newbucket;
+        t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len
       end;
       if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
     end;

testsuite/tests/basic-modules/main.ml

@@ -1,5 +1,5 @@
 (* TEST
-  modules = "offset.ml pr6726.ml pr7427.ml"
+  modules = "offset.ml pr6726.ml pr7427.ml pr4008.ml"
 *)
 
 (* PR#6435 *)
@@ -16,6 +16,7 @@ module M = F (Offset)
 
 let () = M.test (Offset.M.Set.singleton "42")
 let v = Pr6726.Test.v
+let v = Pr4008.v
 
 (* PR#7427 *)
 

testsuite/tests/basic-modules/pr4008.ml

@@ -0,0 +1,6 @@
+module rec M : sig
+  val f : int list -> int list
+end = struct
+  let f = List.map succ
+end
+let v = M.f []

testsuite/tests/misc/sorts.ml

@@ -4164,24 +4164,6 @@ let ainsertion_1 cmp a =
   done;
 ;;
 
-(************************************************************************)
-(* merge sort on lists via arrays *)
-
-let array_to_list_in_place a =
-  let l = Array.length a in
-  let rec loop accu n p =
-    if p <= 0 then accu else begin
-      if p = n then begin
-        Obj.truncate (Obj.repr a) p;
-        loop (a.(p-1) :: accu) (n-1000) (p-1)
-      end else begin
-        loop (a.(p-1) :: accu) n (p-1)
-      end
-    end
-  in
-  loop [] l l
-;;
-
 let array_of_list l len =
   match l with
   | [] -> [| |]
@@ -4199,7 +4181,7 @@ let array_of_list l len =
 let lmerge_0a cmp l =
   let a = Array.of_list l in
   amerge_1e cmp a;
-  array_to_list_in_place a
+  Array.to_list a
 ;;
 
 let lmerge_0b cmp l =
@@ -4207,19 +4189,19 @@ let lmerge_0b cmp l =
   if len > 256 then Gc.minor ();
   let a = array_of_list l len in
   amerge_1e cmp a;
-  array_to_list_in_place a
+  Array.to_list a
 ;;
 
 let lshell_0 cmp l =
   let a = Array.of_list l in
   ashell_2 cmp a;
-  array_to_list_in_place a
+  Array.to_list a
 ;;
 
 let lquick_0 cmp l =
   let a = Array.of_list l in
   aquick_3f cmp a;
-  array_to_list_in_place a
+  Array.to_list a
 ;;
 
 (************************************************************************)

testsuite/tests/tool-toplevel-invocation/print_args.ml

@@ -0,0 +1 @@
+Array.iter (fun x -> print_endline (Filename.basename x)) Sys.argv;;

testsuite/tests/tool-toplevel-invocation/print_args.reference

@@ -0,0 +1,3 @@
+print_args.ml
+foo
+bar

testsuite/tests/tool-toplevel-invocation/test.ml

@@ -40,6 +40,12 @@ compiler_reference = "${test_source_directory}/working_arg.txt.reference"
 compiler_output = "${test_build_directory}/working_arg.output"
 *** check-ocaml-output
 
+** ocaml
+flags = "${test_source_directory}/print_args.ml foo bar"
+compiler_reference = "${test_source_directory}/print_args.reference"
+compiler_output = "${test_build_directory}/print_args.output"
+*** check-ocaml-output
+
 *)
 
 printf "Test succeeds\n";;

toplevel/opttoploop.ml

@@ -607,21 +607,17 @@ let loop ppf =
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
-(* Execute a script.  If [name] is "", read the script from stdin. *)
+external caml_sys_modify_argv : string array -> unit =
+  "caml_sys_modify_argv"
 
-let override_sys_argv args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
+let override_sys_argv new_argv =
+  caml_sys_modify_argv new_argv;
   Arg.current := 0
 
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
 let run_script ppf name args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
-  Arg.current := 0;
+  override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) ();
                    (* Note: would use [Filename.abspath] here, if we had it. *)
   toplevel_env := Compmisc.initial_env();

toplevel/toploop.ml

@@ -565,15 +565,15 @@ let loop ppf =
     | x -> Location.report_exception ppf x; Btype.backtrack snap
   done
 
-(* Execute a script.  If [name] is "", read the script from stdin. *)
+external caml_sys_modify_argv : string array -> unit =
+  "caml_sys_modify_argv"
 
-let override_sys_argv args =
-  let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
-  Array.blit args 0 Sys.argv 0 len;
-  Obj.truncate (Obj.repr Sys.argv) len;
+let override_sys_argv new_argv =
+  caml_sys_modify_argv new_argv;
   Arg.current := 0
 
+(* Execute a script.  If [name] is "", read the script from stdin. *)
+
 let run_script ppf name args =
   override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) ();