Merge pull request #1723 from stedolan/remove-meta-static

Remove Meta.static_{alloc, free}.

Changes

@@ -48,6 +48,9 @@ Working version
 - GPR#1793: add the -m and -M command-line options to ocamlrun
   (Sébastien Hinderer, review by Xavier Clerc and Damien Doligez)
 
+- GPR#1723: Remove internal Meta.static_{alloc,free} primitives.
+  (Stephen Dolan, review by Gabriel Scherer)
+
 ### Tools:
 
 - GPR#1711: the new 'open' flag in OCAMLRUNPARAM takes a comma-separated list of

bytecomp/bytelink.ml

@@ -212,7 +212,7 @@ let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
   check_consistency ppf file_name compunit;
   seek_in inchan compunit.cu_pos;
   let code_block = LongString.input_bytes inchan compunit.cu_codesize in
-  Symtable.ls_patch_object code_block compunit.cu_reloc;
+  Symtable.patch_object code_block compunit.cu_reloc;
   if !Clflags.debug && compunit.cu_debug > 0 then begin
     seek_in inchan compunit.cu_debug;
     let debug_event_list : Instruct.debug_event list = input_value inchan in

bytecomp/emitcode.ml

@@ -442,13 +442,12 @@ let to_memory init_code fun_code =
   init();
   emit init_code;
   emit fun_code;
-  let code = Meta.static_alloc !out_position in
-  LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position;
-  let reloc = List.rev !reloc_info
-  and code_size = !out_position in
+  let code = LongString.create !out_position in
+  LongString.blit !out_buffer 0 code 0 !out_position;
+  let reloc = List.rev !reloc_info in
   let events = !events in
   init();
-  (code, code_size, reloc, events)
+  (code, reloc, events)
 
 (* Emission to a file for a packed library *)
 

bytecomp/emitcode.mli

@@ -28,13 +28,12 @@ val to_file: out_channel -> string -> string ->
                evaluated before this one
              list of instructions to emit *)
 val to_memory: instruction list -> instruction list ->
-                    bytes * int * (reloc_info * int) list * debug_event list
+                    Misc.LongString.t * (reloc_info * int) list * debug_event list
         (* Arguments:
              initialization code (terminated by STOP)
              function code
            Results:
              block of relocatable bytecode
-             size of this block
              relocation information
              debug events *)
 val to_packed_file:

bytecomp/meta.ml

@@ -15,19 +15,15 @@
 
 external global_data : unit -> Obj.t array = "caml_get_global_data"
 external realloc_global_data : int -> unit = "caml_realloc_global"
-external static_alloc : int -> bytes = "caml_static_alloc"
-external static_free : bytes -> unit = "caml_static_free"
-external static_resize : bytes -> int -> bytes = "caml_static_resize"
-external static_release_bytecode : bytes -> int -> unit
-                                 = "caml_static_release_bytecode"
 type closure = unit -> Obj.t
-external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode"
+type bytecode
+external reify_bytecode :
+  bytes array -> Instruct.debug_event list array -> string option ->
+    bytecode * closure
+                           = "caml_reify_bytecode"
+external release_bytecode : bytecode -> unit
+                                 = "caml_static_release_bytecode"
 external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
                                 = "caml_invoke_traced_function"
 external get_section_table : unit -> (string * Obj.t) list
                            = "caml_get_section_table"
-external add_debug_info :
-  bytes -> int -> Instruct.debug_event list array -> unit
-                        = "caml_add_debug_info"
-external remove_debug_info : bytes -> unit
-                           = "caml_remove_debug_info"

bytecomp/meta.mli

@@ -17,19 +17,16 @@
 
 external global_data : unit -> Obj.t array = "caml_get_global_data"
 external realloc_global_data : int -> unit = "caml_realloc_global"
-external static_alloc : int -> bytes = "caml_static_alloc"
-external static_free : bytes -> unit = "caml_static_free"
-external static_release_bytecode : bytes -> int -> unit
-                                 = "caml_static_release_bytecode"
-external static_resize : bytes -> int -> bytes = "caml_static_resize"
 type closure = unit -> Obj.t
-external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode"
+type bytecode
+external reify_bytecode :
+  bytes array -> Instruct.debug_event list array -> string option ->
+    bytecode * closure
+                           = "caml_reify_bytecode"
+external release_bytecode : bytecode -> unit
+                                 = "caml_static_release_bytecode"
 external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
                                 = "caml_invoke_traced_function"
 external get_section_table : unit -> (string * Obj.t) list
                            = "caml_get_section_table"
-external add_debug_info :
-  bytes -> int -> Instruct.debug_event list array -> unit
-                        = "caml_add_debug_info"
-external remove_debug_info : bytes -> unit
-                           = "caml_remove_debug_info"
+

bytecomp/symtable.ml

@@ -175,31 +175,25 @@ let init () =
 
 (* Relocate a block of object bytecode *)
 
-(* Must use the unsafe String.set here because the block may be
-   a "fake" string as returned by Meta.static_alloc. *)
+let patch_int buff pos n =
+  LongString.set buff pos (Char.unsafe_chr n);
+  LongString.set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+  LongString.set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+  LongString.set buff (pos + 3) (Char.unsafe_chr (n asr 24))
 
-let gen_patch_int str_set buff pos n =
-  str_set buff pos (Char.unsafe_chr n);
-  str_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
-  str_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
-  str_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
-
-let gen_patch_object str_set buff patchlist =
+let patch_object buff patchlist =
   List.iter
     (function
         (Reloc_literal sc, pos) ->
-          gen_patch_int str_set buff pos (slot_for_literal sc)
+          patch_int buff pos (slot_for_literal sc)
       | (Reloc_getglobal id, pos) ->
-          gen_patch_int str_set buff pos (slot_for_getglobal id)
+          patch_int buff pos (slot_for_getglobal id)
       | (Reloc_setglobal id, pos) ->
-          gen_patch_int str_set buff pos (slot_for_setglobal id)
+          patch_int buff pos (slot_for_setglobal id)
       | (Reloc_primitive name, pos) ->
-          gen_patch_int str_set buff pos (num_of_prim name))
+          patch_int buff pos (num_of_prim name))
     patchlist
 
-let patch_object = gen_patch_object Bytes.unsafe_set
-let ls_patch_object = gen_patch_object LongString.set
-
 (* Translate structured constants *)
 
 let rec transl_const = function

bytecomp/symtable.mli

@@ -20,8 +20,7 @@ open Cmo_format
 (* Functions for batch linking *)
 
 val init: unit -> unit
-val patch_object: bytes -> (reloc_info * int) list -> unit
-val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit
+val patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit
 val require_primitive: string -> unit
 val initial_global_table: unit -> Obj.t array
 val output_global_map: out_channel -> unit

byterun/caml/backtrace_prim.h

@@ -73,6 +73,14 @@ void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li);
 /* Allocate the caml_backtrace_buffer. Returns 0 on success, -1 otherwise */
 int caml_alloc_backtrace_buffer(void);
 
+#ifndef NATIVE_CODE
+/* These two functions are used by the bytecode runtime when loading
+   and unloading bytecode */
+value caml_add_debug_info(code_t code_start, value code_size,
+                                   value events_heap);
+value caml_remove_debug_info(code_t start);
+#endif
+
 #define BACKTRACE_BUFFER_SIZE 1024
 
 /* Besides decoding backtrace info, [backtrace_prim] has two other

byterun/meta.c

@@ -31,6 +31,7 @@
 #include "caml/mlvalues.h"
 #include "caml/prims.h"
 #include "caml/stacks.h"
+#include "caml/backtrace_prim.h"
 
 #ifndef NATIVE_CODE
 
@@ -49,40 +50,99 @@ CAMLprim value caml_get_section_table(value unit)
                                      caml_section_table_size);
 }
 
-CAMLprim value caml_reify_bytecode(value prog, value len)
-{
-  struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment));
-  value clos;
+struct bytecode {
+  code_t prog;
+  asize_t len;
+};
+#define Bytecode_val(p) ((struct bytecode*)Data_abstract_val(p))
 
+/* Convert a bytes array (= LongString.t) to a contiguous buffer.
+   The result is allocated with caml_stat_alloc */
+static char* buffer_of_bytes_array(value ls, asize_t *len)
+{
+  CAMLparam1(ls);
+  CAMLlocal1(s);
+  asize_t off;
+  char *ret;
+  int i;
+
+  *len = 0;
+  for (i = 0; i < Wosize_val(ls); i++) {
+    s = Field(ls, i);
+    *len += caml_string_length(s);
+  }
+
+  ret = caml_stat_alloc(*len);
+  off = 0;
+  for (i = 0; i < Wosize_val(ls); i++) {
+    size_t s_len;
+    s = Field(ls, i);
+    s_len = caml_string_length(s);
+    memcpy(ret + off, Bytes_val(s), s_len);
+    off += s_len;
+  }
+
+  CAMLreturnT (char*, ret);
+}
+
+CAMLprim value caml_reify_bytecode(value ls_prog, value debuginfo, value digest_opt)
+{
+  CAMLparam3(ls_prog, debuginfo, digest_opt);
+  CAMLlocal3(clos, bytecode, retval);
+  struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment));
+  code_t prog;
+  asize_t len;
+
+  prog = (code_t)buffer_of_bytes_array(ls_prog, &len);
+  caml_add_debug_info(prog, Val_long(len), debuginfo);
   cf->code_start = (char *) prog;
-  cf->code_end = (char *) prog + Long_val(len);
-  cf->digest_computed = 0;
+  cf->code_end = (char *) prog + len;
+  /* match (digest_opt : string option) with */
+  if (Is_block(digest_opt)) {
+    /* | Some digest -> */
+    memcpy(cf->digest, String_val(Field(digest_opt, 0)), 16);
+    cf->digest_computed = 1;
+  } else {
+    /* | None -> */
+    cf->digest_computed = 0;
+  }
   caml_ext_table_add(&caml_code_fragments_table, cf);
 
 #ifdef ARCH_BIG_ENDIAN
-  caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len));
+  caml_fixup_endianness((code_t) prog, len);
 #endif
 #ifdef THREADED_CODE
-  caml_thread_code((code_t) prog, (asize_t) Long_val(len));
+  caml_thread_code((code_t) prog, len);
 #endif
-  caml_prepare_bytecode((code_t) prog, (asize_t) Long_val(len));
+  caml_prepare_bytecode((code_t) prog, len);
   clos = caml_alloc_small (1, Closure_tag);
   Code_val(clos) = (code_t) prog;
-  return clos;
+  bytecode = caml_alloc_small (2, Abstract_tag);
+  Bytecode_val(bytecode)->prog = prog;
+  Bytecode_val(bytecode)->len = len;
+  retval = caml_alloc_small (2, 0);
+  Field(retval, 0) = bytecode;
+  Field(retval, 1) = clos;
+  CAMLreturn (retval);
 }
 
 /* signal to the interpreter machinery that a bytecode is no more
    needed (before freeing it) - this might be useful for a JIT
    implementation */
 
-CAMLprim value caml_static_release_bytecode(value prog, value len)
+CAMLprim value caml_static_release_bytecode(value bc)
 {
+  code_t prog;
+  asize_t len;
   struct code_fragment * cf = NULL, * cfi;
   int i;
+  prog = Bytecode_val(bc)->prog;
+  len = Bytecode_val(bc)->len;
+  caml_remove_debug_info(prog);
   for (i = 0; i < caml_code_fragments_table.size; i++) {
     cfi = (struct code_fragment *) caml_code_fragments_table.contents[i];
     if (cfi->code_start == (char *) prog &&
-        cfi->code_end == (char *) prog + Long_val(len)) {
+        cfi->code_end == (char *) prog + len) {
       cf = cfi;
       break;
     }
@@ -96,10 +156,11 @@ CAMLprim value caml_static_release_bytecode(value prog, value len)
   }
 
 #ifndef NATIVE_CODE
-  caml_release_bytecode((code_t) prog, (asize_t) Long_val(len));
+  caml_release_bytecode(prog, len);
 #else
   caml_failwith("Meta.static_release_bytecode impossible with native code");
 #endif
+  caml_stat_free(prog);
   return Val_unit;
 }
 

otherlibs/dynlink/dynlink.ml

@@ -206,24 +206,17 @@ let check_unsafe_module cu =
 
 (* Load in-core and execute a bytecode object file *)
 
-external register_code_fragment: bytes -> int -> string -> unit
-                               = "caml_register_code_fragment"
-
 let load_compunit ic file_name file_digest compunit =
+  let open Misc in
   check_consistency file_name compunit;
   check_unsafe_module compunit;
   seek_in ic compunit.cu_pos;
   let code_size = compunit.cu_codesize + 8 in
-  let code = Meta.static_alloc code_size in
-  unsafe_really_input ic code 0 compunit.cu_codesize;
-  Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
-  Bytes.unsafe_set code (compunit.cu_codesize + 1) '\000';
-  Bytes.unsafe_set code (compunit.cu_codesize + 2) '\000';
-  Bytes.unsafe_set code (compunit.cu_codesize + 3) '\000';
-  Bytes.unsafe_set code (compunit.cu_codesize + 4) '\001';
-  Bytes.unsafe_set code (compunit.cu_codesize + 5) '\000';
-  Bytes.unsafe_set code (compunit.cu_codesize + 6) '\000';
-  Bytes.unsafe_set code (compunit.cu_codesize + 7) '\000';
+  let code = LongString.create code_size in
+  LongString.input_bytes_into code ic compunit.cu_codesize;
+  LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
+  LongString.blit_string "\000\000\000\001\000\000\000" 0
+                     code (compunit.cu_codesize + 1) 7;
   let initial_symtable = Symtable.current_state() in
   begin try
     Symtable.patch_object code compunit.cu_reloc;
@@ -242,16 +235,15 @@ let load_compunit ic file_name file_digest compunit =
      digest of file contents + unit name.
      Unit name is needed for .cma files, which produce several code fragments.*)
   let digest = Digest.string (file_digest ^ compunit.cu_name) in
-  register_code_fragment code code_size digest;
   let events =
     if compunit.cu_debug = 0 then [| |]
     else begin
       seek_in ic compunit.cu_debug;
       [| input_value ic |]
     end in
-  Meta.add_debug_info code code_size events;
   begin try
-    ignore((Meta.reify_bytecode code code_size) ())
+    let _, clos = Meta.reify_bytecode code events (Some digest) in
+    ignore (clos ())
   with exn ->
     Symtable.restore_state initial_symtable;
     raise exn

toplevel/topdirs.ml

@@ -124,10 +124,10 @@ let load_compunit ic filename ppf compunit =
   check_consistency ppf filename compunit;
   seek_in ic compunit.cu_pos;
   let code_size = compunit.cu_codesize + 8 in
-  let code = Meta.static_alloc code_size in
-  unsafe_really_input ic code 0 compunit.cu_codesize;
-  Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
-  String.unsafe_blit "\000\000\000\001\000\000\000" 0
+  let code = LongString.create code_size in
+  LongString.input_bytes_into code ic compunit.cu_codesize;
+  LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
+  LongString.blit_string "\000\000\000\001\000\000\000" 0
                      code (compunit.cu_codesize + 1) 7;
   let initial_symtable = Symtable.current_state() in
   Symtable.patch_object code compunit.cu_reloc;
@@ -138,10 +138,10 @@ let load_compunit ic filename ppf compunit =
       seek_in ic compunit.cu_debug;
       [| input_value ic |]
     end in
-  Meta.add_debug_info code code_size events;
   begin try
     may_trace := true;
-    ignore((Meta.reify_bytecode code code_size) ());
+    let _bytecode, closure = Meta.reify_bytecode code events None in
+    ignore (closure ());
     may_trace := false;
   with exn ->
     record_backtrace ();

toplevel/toploop.ml

@@ -165,34 +165,26 @@ let load_lambda ppf lam =
     fprintf ppf "%a%a@."
     Printinstr.instrlist init_code
     Printinstr.instrlist fun_code;
-  let (code, code_size, reloc, events) =
+  let (code, reloc, events) =
     Emitcode.to_memory init_code fun_code
   in
-  Meta.add_debug_info code code_size [| events |];
   let can_free = (fun_code = []) in
   let initial_symtable = Symtable.current_state() in
   Symtable.patch_object code reloc;
   Symtable.check_global_initialized reloc;
   Symtable.update_global_table();
   let initial_bindings = !toplevel_value_bindings in
+  let bytecode, closure = Meta.reify_bytecode code [| events |] None in
   try
     may_trace := true;
-    let retval = (Meta.reify_bytecode code code_size) () in
+    let retval = closure () in
     may_trace := false;
-    if can_free then begin
-      Meta.remove_debug_info code;
-      Meta.static_release_bytecode code code_size;
-      Meta.static_free code;
-    end;
+    if can_free then Meta.release_bytecode bytecode;
     Result retval
   with x ->
     may_trace := false;
+    if can_free then Meta.release_bytecode bytecode;
     record_backtrace ();
-    if can_free then begin
-      Meta.remove_debug_info code;
-      Meta.static_release_bytecode code code_size;
-      Meta.static_free code;
-    end;
     toplevel_value_bindings := initial_bindings; (* PR#6211 *)
     Symtable.restore_state initial_symtable;
     Exception x

utils/misc.ml

@@ -416,19 +416,26 @@ module LongString = struct
       set dst (dstoff + i) (get src (srcoff + i))
     done
 
+  let blit_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (String.get src (srcoff + i))
+    done
+
   let output oc tbl pos len =
     for i = pos to pos + len - 1 do
       output_char oc (get tbl i)
     done
 
-  let unsafe_blit_to_bytes src srcoff dst dstoff len =
-    for i = 0 to len - 1 do
-      Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i))
-    done
+  let input_bytes_into tbl ic len =
+    let count = ref len in
+    Array.iter (fun str ->
+      let chunk = min !count (Bytes.length str) in
+      really_input ic str 0 chunk;
+      count := !count - chunk) tbl
 
   let input_bytes ic len =
     let tbl = create len in
-    Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl;
+    input_bytes_into tbl ic len;
     tbl
 end
 

utils/misc.mli

@@ -206,8 +206,9 @@ module LongString :
     val get : t -> int -> char
     val set : t -> int -> char -> unit
     val blit : t -> int -> t -> int -> int -> unit
+    val blit_string : string -> int -> t -> int -> int -> unit
     val output : out_channel -> t -> int -> int -> unit
-    val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
+    val input_bytes_into : t -> in_channel -> int -> unit
     val input_bytes : in_channel -> int -> t
   end