debug_message_callback may raise Ffi_stubs.CallToExpiredClosure

[edwintorok]

I don't have OpenGL 4.x capable hardware, but in my experiments with the ARB_debug_output extension on 3.x I got an Ffi_stubs.CallToExpiredClosure.

The wrap_cb in the following function (which is identical to the one in Tgl4) can be garbage collected (it is used as a weak reference in ctypes):

  let debug_message_callback f =
    let wrap_cb src typ id sev len msg _ =
      let s = String.create len in
      for i = 0 to len - 1 do s.[i] <- !@ (msg +@ i) done;
      f src typ id sev s
    in
    debug_message_callback wrap_cb null

I worked it around by storing the callback in a global:

+let callback = ref None
 let debug_message_callback f =
   let wrap_cb src typ id sev len msg _ =
     let s = String.create len in
     for i = 0 to len - 1 do s.[i] <- !@ (msg +@ i) done;
     f src typ id sev s
   in
+  callback := Some wrap_cb; (* prevent Ffi_stubs.CallToExpiredClosure *)
   debug_message_callback wrap_cb null

Here is a testcase for Tgl4:

open Tsdl
open Tgl4
let check = function
  | `Ok r -> r
  | `Error -> failwith (Sdl.get_error ())
let set attr v = check (Sdl.gl_set_attribute attr v)

let string_of_source e =
  if e = Gl.debug_source_api then "API"
  else if e = Gl.debug_source_window_system then "Window System"
  else if e = Gl.debug_source_shader_compiler then "Shader Compiler"
  else if e = Gl.debug_source_third_party then "Third Party"
  else if e = Gl.debug_source_application then "Application"
  else if e = Gl.debug_source_other then "Other"
  else "??"

let string_of_type e =
  if e = Gl.debug_type_error then "Error"
  else if e = Gl.debug_type_deprecated_behavior then "Deprecated Functionality"
  else if e = Gl.debug_type_portability then "Portability"
  else if e = Gl.debug_type_performance then "Performance"
  else if e = Gl.debug_type_other then "Other"
  else "??"

let string_of_severity e =
  if e = Gl.debug_severity_high then Sdl.log_error Sdl.Log.category_application
  else if e = Gl.debug_severity_medium then Sdl.log_warn Sdl.Log.category_application
  else if e = Gl.debug_severity_low then Sdl.log_verbose Sdl.Log.category_application
  else Sdl.log

let debug_func src typ _id severity msg =
  let log = string_of_severity severity in
  log "%s from %s: %s" (string_of_type typ) (string_of_source src) msg

let () =
  check (Sdl.init Sdl.Init.video);
  set Sdl.Gl.context_major_version 4;
  set Sdl.Gl.context_minor_version 0;
  set Sdl.Gl.context_profile_mask Sdl.Gl.context_profile_core;
  set Sdl.Gl.context_flags Sdl.Gl.context_debug_flag;
  Sdl.log_set_all_priority Sdl.Log.priority_verbose;
  let attrs = Sdl.Window.(opengl + resizable) in
  let win = check(Sdl.create_window ~w:100 ~h:100 "test" attrs) in
  let ctx = check (Sdl.gl_create_context win) in
  Gl.enable Gl.debug_output_synchronous;
  Gl.debug_message_callback debug_func;
  Gl.debug_message_control Gl.dont_care Gl.dont_care Gl.dont_care 0 None
    true;
  Gc.full_major ();
  let msg = "test" in
  Gl.debug_message_insert
    Gl.debug_source_application Gl.debug_type_other 42 Gl.debug_severity_low
    (String.length msg) msg;
  Sdl.gl_delete_context ctx;
  Sdl.destroy_window win;
  Sdl.quit ();

[dbuenzli]

Ah yes I once asked on ctypes mailing list what was happening with callbacks but didn't get any answer (unfortunately the links in that message are outdated, github should not provide links to master by default). So I now have some of my answers.

Before doing what you suggest I need to check whether multiple debug callbacks can be installed by the client in which case I'll let the burden of keeping a reference on the client of the library. There also stub generation coming to ctypes that may change the game and ask a few questions (e.g. do we still get the dlsym lookup for free, which is essential for OpenGL) so I'll wait and see for now.

[whitequark]

@dbuenzli FYI you can use the "y" shortcut to make github expand the URL to its canonical form.

[dbuenzli]

I know, but I often forget to to so. Github is providing the wrong default, when you are making URI references you most often want to refer to a stable resource.

[gantsevdenis]

Sorry to bother anyone But I reliably hit "Ffi_stubs.CallToExpiredClosure" every single time I attach debug_message_callback with Tgl4

[dbuenzli]

I'm sorry I absolutely don't have any of the context here in my head. If something needs to be done on the tgls side I'll gladly take a patch.

Other than that @gantsevdenis, do you keep a reference on your side to the exact closure you register ? That, I guess should solve the problem.

[dbuenzli]

Ah but you I guess you can't since it's on wrap_cb that the root should be kept.

[edwintorok]

The lifetime of funptr and its behaviour wrt to OCaml runtime lock is now documented: https://github.com/ocamllabs/ocaml-ctypes/blob/9048ac78b885cc3debeeb020c56ea91f459a4d33/src/ctypes-foreign/foreign.mli#L80-L85. There is a dynamic_funptr with explicit alloc/dealloc that can be used to avoid the GC freeing things too soon. Otherwise see just how complicated it is to carefully keep references to everything to avoid the expired closure exception: https://github.com/ocamllabs/ocaml-ctypes/blob/261fe071fad17ab323d8d2b82df2aec593e64e3f/tests/test-callback_lifetime/test_callback_lifetime.ml#L108-L136

I've opened a PR to attempt to fix this, including a slightly adjusted version of the above testcase, and I now have OpenGL4 capable hardware to test it on, and seems to have worked fine.

[dbuenzli]

@gantsevdenis could you tell us if that works you by trying with opam pin tgls --dev

[gantsevdenis]

@dbuenzli I confirm it totally works now!