flambda-backend: Fix for naked pointer problem in unsafe_get_global_value (#2317)

Author: mshinwell

otherlibs/dynlink/byte/dynlink.ml

@@ -219,6 +219,9 @@ module Bytecode = struct
     | exception _ -> None
     | obj -> Some obj
 
+  let does_symbol_exist ~bytecode_or_asm_symbol =
+    Option.is_some (unsafe_get_global_value ~bytecode_or_asm_symbol)
+
   let finish (ic, _filename, _digest) =
     close_in ic
 end

otherlibs/dynlink/dynlink.ml

@@ -62,6 +62,10 @@ let unsafe_get_global_value ~bytecode_or_asm_symbol =
   if is_native then N.unsafe_get_global_value ~bytecode_or_asm_symbol
   else B.unsafe_get_global_value ~bytecode_or_asm_symbol
 
+let does_symbol_exist ~bytecode_or_asm_symbol =
+  if is_native then N.does_symbol_exist ~bytecode_or_asm_symbol
+  else B.does_symbol_exist ~bytecode_or_asm_symbol
+
 let adapt_filename file =
   if is_native then N.adapt_filename file
   else B.adapt_filename file

otherlibs/dynlink/dynlink.mli

@@ -166,6 +166,10 @@ val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option
     The accessible values are those in the main program and those provided by
     previous calls to [loadfile].
 
+    ** This function may only be used to retrieve the addresses of symbols
+    that are valid OCaml values.  It cannot be used to retrieve e.g. code
+    pointers. **
+
     This function is deemed "unsafe" as there is no type safety provided.
 
     When executing in bytecode, this function uses [Symtable]. As a cautionary
@@ -178,3 +182,8 @@ val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option
     client's version of [Symtable]). This is why we can't use [Dynlink] from the
     toplevel interactive loop, in particular.
 *)
+
+(** Like [unsafe_get_global_value], but only tests whether the given symbol
+    exists, and in native code may be used for any symbol (whether or not such
+    symbol points at a valid OCaml value). *)
+val does_symbol_exist : bytecode_or_asm_symbol:string -> bool

otherlibs/dynlink/dynlink_common.ml

@@ -402,6 +402,12 @@ module Make (P : Dynlink_platform_intf.S) = struct
         P.unsafe_get_global_value ~bytecode_or_asm_symbol
       )
 
+  let does_symbol_exist ~bytecode_or_asm_symbol =
+    with_lock (fun _ ->
+        (* The bytecode implementation reads the global symtable *)
+        P.does_symbol_exist ~bytecode_or_asm_symbol
+      )
+
   let is_native = P.is_native
   let adapt_filename = P.adapt_filename
 end

otherlibs/dynlink/dynlink_common.mli

@@ -24,6 +24,7 @@ module Make (_ : Dynlink_platform_intf.S) : sig
   val loadfile : string -> unit
   val loadfile_private : string -> unit
   val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option
+  val does_symbol_exist : bytecode_or_asm_symbol:string -> bool
   val adapt_filename : string -> string
   val set_allowed_units : string list -> unit
   val allow_only: string list -> unit

otherlibs/dynlink/dynlink_platform_intf.ml

@@ -78,5 +78,7 @@ module type S = sig
 
   val unsafe_get_global_value : bytecode_or_asm_symbol:string -> Obj.t option
 
+  val does_symbol_exist : bytecode_or_asm_symbol:string -> bool
+
   val finish : handle -> unit
 end

otherlibs/dynlink/native/dynlink.ml

@@ -53,6 +53,9 @@ module Native = struct
     = "caml_sys_exit" "caml_natdynlink_globals_inited"
   external ndl_loadsym : string -> Obj.t
     = "caml_sys_exit" "caml_natdynlink_loadsym"
+  external ndl_existssym : string -> bool
+    = "caml_sys_exit" "caml_natdynlink_existssym"
+    [@@noalloc]
 
   module Unit_header = struct
     type t = Cmxs_format.dynunit
@@ -161,6 +164,9 @@ module Native = struct
     | exception _ -> None
     | obj -> Some obj
 
+  let does_symbol_exist ~bytecode_or_asm_symbol =
+    ndl_existssym bytecode_or_asm_symbol
+
   let finish _handle = ()
 end
 

runtime/dynlink_nat.c

@@ -204,7 +204,16 @@ CAMLprim value caml_natdynlink_loadsym(value symbol)
   CAMLparam1 (symbol);
   CAMLlocal1 (sym);
 
+  /* Note that this can only be used for symbols which are valid OCaml
+     values, otherwise a naked pointer would be returned. */
+
   sym = (value) caml_globalsym(String_val(symbol));
   if (!sym) caml_failwith(String_val(symbol));
   CAMLreturn(sym);
 }
+
+CAMLprim value caml_natdynlink_existssym(value symbol)
+{
+  void* sym = caml_globalsym(String_val(symbol));
+  return sym != NULL ? Val_true : Val_false;
+}

runtime4/dynlink_nat.c

@@ -221,7 +221,16 @@ CAMLprim value caml_natdynlink_loadsym(value symbol)
   CAMLparam1 (symbol);
   CAMLlocal1 (sym);
 
+  /* Note that this can only be used for symbols which are valid OCaml
+     values, otherwise a naked pointer would be returned. */
+
   sym = (value) caml_globalsym(String_val(symbol));
   if (!sym) caml_failwith(String_val(symbol));
   CAMLreturn(sym);
 }
+
+CAMLprim value caml_natdynlink_existssym(value symbol)
+{
+  void* sym = caml_globalsym(String_val(symbol));
+  return sym != NULL ? Val_true : Val_false;
+}

toplevel/native/tophooks.ml

@@ -28,7 +28,7 @@ let lookup sym =
   Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym
 
 let need_symbol sym =
-  Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym)
+  not (Dynlink.does_symbol_exist ~bytecode_or_asm_symbol:sym)
 
 let dll_run dll entry =
   match (try Result (Obj.magic (ndl_run_toplevel dll entry))