Remove all callback global roots.

Author: toots

examples/decode.ml

@@ -1,3 +1,5 @@
+let () = Printexc.record_backtrace true
+
 let output_int chan n =
   output_char chan (char_of_int ((n lsr 0) land 0xff));
   output_char chan (char_of_int ((n lsr 8) land 0xff));
@@ -100,11 +102,13 @@ let process () =
           try
             Flac.Decoder.process dec;
             Flac.Decoder.state dec
-          with Ogg.Not_enough_data -> (
-            try
-              fill ();
-              process ()
-            with Ogg.End_of_stream | Ogg.Not_enough_data -> `End_of_stream)
+          with
+            | Ogg.End_of_stream -> `End_of_stream
+            | Ogg.Not_enough_data -> (
+                try
+                  fill ();
+                  process ()
+                with Ogg.End_of_stream | Ogg.Not_enough_data -> `End_of_stream)
         in
         (process, info, meta)
       in

src/flac.ml

@@ -103,6 +103,7 @@ module Decoder = struct
   external init : t -> unit = "ocaml_flac_decoder_init"
 
   let create ?seek ?tell ?length ?eof ~read ~write () =
+    let write pcm = write (Array.copy pcm) in
     let dec = alloc ~seek ~tell ~length ~eof ~read ~write () in
     Gc.finalise cleanup dec;
     init dec;
@@ -183,7 +184,7 @@ module Encoder = struct
     (string * string) array ->
     seek:(int64 -> unit) option ->
     tell:(unit -> int64) option ->
-    write:(bytes -> unit) ->
+    write:(bytes -> int -> unit) ->
     params ->
     priv = "ocaml_flac_encoder_alloc"
 
@@ -193,6 +194,7 @@ module Encoder = struct
   let create ?(comments = []) ?seek ?tell ~write p =
     if p.channels <= 0 then raise Invalid_data;
     let comments = Array.of_list comments in
+    let write b len = write (Bytes.sub b 0 len) in
     let enc = alloc comments ~seek ~tell ~write p in
     Gc.finalise cleanup enc;
     init enc;

src/flac_ogg.ml

@@ -67,12 +67,16 @@ module Encoder = struct
   type priv
   type t = { encoder : Flac.Encoder.t; first_pages : Ogg.Page.t list }
 
-  external create :
+  external alloc :
     (string * string) array ->
+    seek:(int64 -> unit) option ->
+    tell:(unit -> int64) option ->
+    write:(bytes -> int -> unit) ->
     Flac.Encoder.params ->
-    nativeint ->
-    (bytes -> unit) ->
-    priv = "ocaml_flac_encoder_ogg_create"
+    priv = "ocaml_flac_encoder_alloc"
+
+  external cleanup : priv -> unit = "ocaml_flac_cleanup_encoder"
+  external init : priv -> nativeint -> unit = "ocaml_flac_encoder_ogg_init"
 
   let create ?(comments = []) ~serialno ~write params =
     if params.Flac.Encoder.channels <= 0 then raise Flac.Encoder.Invalid_data;
@@ -84,15 +88,18 @@ module Encoder = struct
       match !header with
         | Some h ->
             header := None;
-            write (Bytes.unsafe_to_string h, Bytes.unsafe_to_string p)
+            write (h, p)
         | None -> header := Some p
     in
     let write_first_page p = first_pages := p :: !first_pages in
     let write =
       write_wrap (fun p ->
           if !first_pages_parsed then write p else write_first_page p)
     in
-    let enc = create comments params serialno write in
+    let write b len = write (Bytes.sub_string b 0 len) in
+    let enc = alloc comments ~seek:None ~tell:None ~write params in
+    Gc.finalise cleanup enc;
+    init enc serialno;
     first_pages_parsed := true;
     assert (!header = None);
     { encoder = Obj.magic (enc, params); first_pages = List.rev !first_pages }

src/flac_ogg_stubs.c

@@ -59,16 +59,12 @@ CAMLprim value ocaml_flac_decoder_packet_data(value v) {
 
 /* Encoder */
 
-CAMLprim value ocaml_flac_encoder_ogg_create(value comments, value params,
-                                             value _serialno, value _write_cb) {
-  CAMLparam4(comments, params, _serialno, _write_cb);
-  CAMLlocal2(tmp, ret);
+CAMLprim value ocaml_flac_encoder_ogg_init(value _enc, value _serialno) {
+  CAMLparam2(_enc, _serialno);
 
   intnat serialno = Nativeint_val(_serialno);
 
-  ret =
-      ocaml_flac_encoder_alloc(comments, Val_none, Val_none, _write_cb, params);
-  ocaml_flac_encoder *enc = Encoder_val(ret);
+  ocaml_flac_encoder *enc = Encoder_val(_enc);
 
   caml_release_runtime_system();
   FLAC__stream_encoder_set_ogg_serial_number(enc->encoder, serialno);
@@ -77,7 +73,7 @@ CAMLprim value ocaml_flac_encoder_ogg_create(value comments, value params,
                                        (void *)&enc->callbacks);
   caml_acquire_runtime_system();
 
-  CAMLreturn(ret);
+  CAMLreturn(Val_unit);
 }
 
 /* Ogg skeleton interface */

src/flac_stubs.c

@@ -195,6 +195,7 @@ CAMLprim value ocaml_flac_cleanup_decoder(value e) {
   caml_remove_generational_global_root(&dec->callbacks.length_cb);
   caml_remove_generational_global_root(&dec->callbacks.write_cb);
   caml_remove_generational_global_root(&dec->callbacks.buffer);
+  caml_remove_generational_global_root(&dec->callbacks.output);
 
   return Val_unit;
 }
@@ -328,7 +329,10 @@ static FLAC__bool dec_eof_callback(const FLAC__StreamDecoder *decoder,
   value ret = caml_callback(callbacks->eof_cb, Val_unit);
   caml_release_runtime_system();
 
-  return ret == Val_true;
+  if (ret == Val_true)
+    return true;
+
+  return false;
 }
 
 FLAC__StreamDecoderReadStatus static dec_read_callback(
@@ -383,27 +387,16 @@ dec_write_callback(const FLAC__StreamDecoder *decoder, const FLAC__Frame *frame,
   ocaml_flac_register_thread();
   caml_acquire_runtime_system();
 
-  value data = caml_alloc_tuple(channels);
-  caml_register_generational_global_root(&data);
-
   int c, i;
   for (c = 0; c < channels; c++) {
-    Store_field(data, c, caml_alloc(samples * Double_wosize, Double_array_tag));
+    Store_field(callbacks->output, c,
+                caml_alloc(samples * Double_wosize, Double_array_tag));
     for (i = 0; i < samples; i++)
-      Store_double_field(Field(data, c), i,
+      Store_double_field(Field(callbacks->output, c), i,
                          sample_to_double(buffer[c][i], bps));
   }
 
-  value ret = caml_callback_exn(callbacks->write_cb, data);
-  caml_remove_generational_global_root(&data);
-
-  if (Is_exception_result(ret)) {
-    ret = Extract_exception(ret);
-    caml_remove_generational_global_root(&data);
-    caml_raise(ret);
-  }
-
-  caml_remove_generational_global_root(&data);
+  caml_callback(callbacks->write_cb, callbacks->output);
 
   caml_release_runtime_system();
 
@@ -449,6 +442,9 @@ CAMLprim value ocaml_flac_decoder_alloc_native(value seek, value tell,
   dec->callbacks.buffer = caml_alloc_string(dec->callbacks.buflen);
   caml_register_generational_global_root(&dec->callbacks.buffer);
 
+  dec->callbacks.output = Val_none;
+  caml_register_generational_global_root(&dec->callbacks.output);
+
   dec->callbacks.info = NULL;
   dec->callbacks.meta = NULL;
 
@@ -471,7 +467,7 @@ CAMLprim value ocaml_flac_decoder_alloc_bytecode(value *argv, int argn) {
 CAMLprim value ocaml_flac_decoder_init(value _dec) {
   CAMLparam1(_dec);
 
-  ocaml_flac_decoder *dec = Decoder_val(dec);
+  ocaml_flac_decoder *dec = Decoder_val(_dec);
 
   // Intialize decoder
   caml_release_runtime_system();
@@ -482,6 +478,9 @@ CAMLprim value ocaml_flac_decoder_init(value _dec) {
   FLAC__stream_decoder_process_until_end_of_metadata(dec->decoder);
   caml_acquire_runtime_system();
 
+  caml_modify_generational_global_root(
+      &dec->callbacks.output, caml_alloc_tuple(dec->callbacks.info->channels));
+
   CAMLreturn(Val_unit);
 }
 
@@ -656,8 +655,8 @@ enc_write_callback(const FLAC__StreamEncoder *encoder,
     if (callbacks->buflen < len)
       len = callbacks->buflen;
 
-    memcpy(Bytes_val(callbacks->buffer), buffer, len);
-    caml_callback(callbacks->write_cb, callbacks->buffer);
+    memcpy(Bytes_val(callbacks->buffer), buffer + pos, len);
+    caml_callback2(callbacks->write_cb, callbacks->buffer, Val_int(len));
 
     pos += len;
   }

src/flac_stubs.h

@@ -40,6 +40,7 @@ typedef struct ocaml_flac_decoder_callbacks {
   value length_cb;
   value eof_cb;
   value write_cb;
+  value output;
   value buffer;
   int buflen;
   FLAC__StreamMetadata_StreamInfo *info;