Kaz Kylheku | 12 Mar 03:04 2008
Picon

dlvsym support in FFI

Hi All,

I have a patch for CLISP (current CVS) which adds
versioned symbol support to the dynamic FFI.

Versioned symbol support is required in order to access
versioned symbols.

Quickie background:

On a Linux system, if you view "nm /lib/libc.so.6" you find symbols with  <at> 
and  <at>  <at>  in their name, like "__xstat64 <at> GLIBC_2.1".    This is a versioned
symbol and can be retrieved with dlvsym("__xstat64", "GLIBC_2.1").

A dlsym("__xstat64") lookup may or may not get you that one.

C programs compiled against glibc (or other libraries) are encoded with
the version information, so they ask for the correct symbol. If
a function is superseded with a new version which is not
backward compatible at the ABI level, programs which were
compiled against the old version of the library continue to work, because
they request the old version. This is nicely transparent to the C
programmer; the linker simply pulls out the latest version of the
function that is available at the time the program is built and sticks in
the versioned reference.

CLISP programs using the FFI need also to be able to pin to a specific
version of a function, otherwise they may work with some library
installations but break with others (which are newer).

Implementation:

I decided that the easiest way to get this working in CLISP is to extend
the idea of what a foreign name is. Currently, it must be a string atom.
I expanded the concept so that a foreign symbol name can be either
a string, or a cons cell whose CAR and CDR are strings. This pair
of strings represents a versioned symbol.

The low-level FFI plumbing recognizes the cons, and deals with
it accordingly through dlvsym() rather than dlsym(). On platforms
where this kind of thing is not available, the lookup for a versioned
symbol simply fails.

Sample run:

[1]> (use-package :ffi)
T
[2]> (def-call-out stat (:language :stdc) (:arguments) (:return-type
int) (:library "libc.so.6") (:name ("__xstat64" . "GLIBC_2.3")))

** - Continuable Error
FFI::FIND-FOREIGN-FUNCTION: no dynamic object named
      ("__xstat64" . "GLIBC_2.3")
     in library "libc.so.6"
If you continue (by typing 'continue'): Skip foreign object creation
The following restarts are also available:
ABORT          :R1      Abort main loop
Break 1 [3]> :a

Okay, here I requested a nonexistent version of __xstat64 from the
library, so it failed.
(I'm not getting the argument list right, because I don't care about
that in this test).

[4]> (def-call-out stat (:language :stdc) (:arguments) (:return-type
int) (:library "libc.so.6") (:name ("__xstat64" . "GLIBC_2.2")))
STAT

And this one works!

[5]> (def-call-out stat (:language :stdc) (:arguments) (:return-type
int) (:library "libc.so.6") (:name ("__xstat64" . "GLIBC_2.1")))
STAT

This works also, but gets us a different function; an older version of
__xstat64.
This one takes a different ``struct stat64'' parameter, so to call it properly,
we'd use a different FFI definition for the stat buffer from the one used
for __xstat64 <at> GLIBC_2.2.

[6]> (def-call-out stat (:language :stdc) (:arguments) (:return-type
int) (:library "libc.so.6") (:name ("__xstat64" . "GLIBC_2.0")))

** - Continuable Error
FFI::FIND-FOREIGN-FUNCTION: no dynamic object named
      ("__xstat64" . "GLIBC_2.0")
     in library "libc.so.6"
If you continue (by typing 'continue'): Skip foreign object creation
The following restarts are also available:
ABORT          :R1      Abort main loop
Break 1 [7]> :a

No such thing, again.

[8]> (def-call-out stat (:language :stdc) (:arguments) (:return-type
int) (:library "libc.so.6") (:name "__xstat64"))
STAT

This works, of course, through dlsym. It gets us the default version
of __xstat64
(the one marked by a double  <at>  <at> ).

The patches:

I can mail a proper tarball of these on request.

Index: clisp/src/aclocal.m4
===================================================================
--- clisp.orig/src/aclocal.m4   2008-03-11 16:22:48.718797000 -0800
+++ clisp/src/aclocal.m4        2008-03-11 16:53:43.429462000 -0800
 <at>  <at>  -6016,7 +6016,7  <at>  <at> 
 AC_CHECK_HEADERS(dlfcn.h)
 if test "$ac_cv_header_dlfcn_h" = yes; then
   AC_SEARCH_LIBS(dlopen, dl)
-  AC_CHECK_FUNCS(dlopen dlsym dlerror dlclose)
+  AC_CHECK_FUNCS(dlopen dlsym dlvsym dlerror dlclose)
 fi
 ])

Index: clisp/src/config.h.in
===================================================================
--- clisp.orig/src/config.h.in  2008-03-11 16:22:48.759791000 -0800
+++ clisp/src/config.h.in       2008-03-11 16:53:43.455448000 -0800
 <at>  <at>  -169,6 +169,9  <at>  <at> 
 /* Define to 1 if you have the `dlsym' function. */
 #undef HAVE_DLSYM

+/* Define to 1 if you have the `dlvsym' function. */
+#undef HAVE_DLVSYM
+
 /* Define to 1 if you have the `fchmod' function. */
 #undef HAVE_FCHMOD

Index: clisp/src/configure
===================================================================
--- clisp.orig/src/configure    2008-03-11 16:22:48.801811000 -0800
+++ clisp/src/configure 2008-03-11 16:53:43.772453000 -0800
 <at>  <at>  -49776,7 +49776,7  <at>  <at> 

-for ac_func in dlopen dlsym dlerror dlclose
+for ac_func in dlopen dlsym dlvsym dlerror dlclose
 do
 as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
 { echo "$as_me:$LINENO: checking for $ac_func" >&5
Index: clisp/src/lispbibl.d
===================================================================
--- clisp.orig/src/lispbibl.d   2008-03-11 16:22:48.833802000 -0800
+++ clisp/src/lispbibl.d        2008-03-11 16:53:43.969450000 -0800
 <at>  <at>  -10901,6 +10901,10  <at>  <at> 
  name is the name of the function (or variable) in the library */
 extern void* find_name (void *handle, const char *name);
 /* used by FOREIGN and spvw.d:dynload_modules() */
+
+/* Find a versioned symbol, on a platform that supports it.
+   Falls back on find_name if not supported. */
+extern void* find_versioned_name (void *handle, const char *name,
const char *ver);
 #endif

 #if defined(DYNAMIC_MODULES)
Index: clisp/src/spvw.d
===================================================================
--- clisp.orig/src/spvw.d       2008-03-11 16:22:48.876796000 -0800
+++ clisp/src/spvw.d    2008-03-11 16:53:44.069449000 -0800
 <at>  <at>  -3623,6 +3623,20  <at>  <at> 
   return ret;
 }

+/* find versioned symbol in the dynamic library.
+   If this functionality is not supported, then the symbol
+   is not found, even if the name does exist in the library. */
+global void* find_versioned_name (void *handle, const char *name,
+                                  const char *ver) {
+  var void *ret = NULL;
+#ifdef HAVE_DLVSYM
+  ret = dlvsym(handle,name,ver);
+#else
+  unused(ver);
+#endif
+  return ret;
+}
+
 #endif

 /* --------------------------------------------------------------------------
Index: clisp/src/foreign.d
===================================================================
--- clisp.orig/src/foreign.d    2008-03-11 16:22:48.935798000 -0800
+++ clisp/src/foreign.d 2008-03-11 16:53:44.172464000 -0800
 <at>  <at>  -667,6 +667,28  <at>  <at> 
   return fa;
 }

+/* Coerce: string -> simple-string
+           (string string) -> (simple-string simple-string) */
+local maygc object coerce_ss_name(object name)
+{
+  if (consp(name)) {
+    var object orig_name = Car(name);
+    var object orig_ver = Cdr(name);
+    var object ss_name = coerce_ss(orig_name);
+    var object ss_ver = coerce_ss(orig_ver);
+
+    if (eq(orig_name, ss_name) && eq(orig_ver, ss_ver))
+      return name;
+
+    var object cons = allocate_cons();
+    Car(cons) = ss_name;
+    Cdr(cons) = ss_ver;
+    return cons;
+  } else {
+    return coerce_ss(name);
+  }
+}
+
 /* (FFI:FOREIGN-FUNCTION address c-type &key name) constructor */
 LISPFUN(foreign_function,seclass_read,2,0,norest,key,1,(kw(name)) )
 {
 <at>  <at>  -699,7 +721,7  <at>  <at> 
   /* TODO need to visit callback interaction */
   if (nullp(TheFfunction(ff)->ff_name) && !missingp(STACK_0)) {
     pushSTACK(ff);
-    STACK_1 = coerce_ss(STACK_1);
+    STACK_1 = coerce_ss_name(STACK_1);
     ff = popSTACK();
     TheFfunction(ff)->ff_name = STACK_0;
   }
 <at>  <at>  -2491,7 +2513,7  <at>  <at> 
 /* (FFI::FIND-FOREIGN-VARIABLE foreign-variable-name foreign-type
      foreign-library foreign-offset) */
 LISPFUNN(find_foreign_variable,4) {
-  STACK_3 = coerce_ss(STACK_3);
+  STACK_3 = coerce_ss_name(STACK_3);
   VALUES1(nullp(STACK_1) ? lookup_foreign_variable(&STACK_3,&STACK_2)
           : foreign_library_variable(&STACK_3,&STACK_2,&STACK_1,&STACK_0));
   skipSTACK(4);
 <at>  <at>  -2517,7 +2539,7  <at>  <at> 
     goto foreign_variable_restart;
   }
   fa = check_faddress_valid(fa);
-  if (!missingp(STACK_0)) STACK_0 = coerce_ss(STACK_0);
+  if (!missingp(STACK_0)) STACK_0 = coerce_ss_name(STACK_0);
   var object fvar = allocate_fvariable();
   var object fvd = STACK_1;
   var struct foreign_layout sas;
 <at>  <at>  -3228,7 +3250,7  <at>  <at> 
 /* (FFI::FIND-FOREIGN-FUNCTION foreign-function-name foreign-type properties
      foreign-library foreign-offset) */
 LISPFUNN(find_foreign_function,5) {
-  STACK_4 = coerce_ss(STACK_4);
+  STACK_4 = coerce_ss_name(STACK_4);
   STACK_3 = check_foreign_function_type(STACK_3);
   VALUES1(nullp(STACK_1) ? lookup_foreign_function(&STACK_4,&STACK_3,&STACK_2)
           : foreign_library_function(&STACK_4,&STACK_3,&STACK_2,
 <at>  <at>  -4232,11 +4254,22  <at>  <at> 
  can trigger GC */
 local maygc void* object_handle (object library, object name) {
   var void * address;
-  with_string_0(name,O(foreign_encoding),namez, {
-    begin_system_call();
-    address = find_name(TheFpointer(Car(Cdr(library)))->fp_pointer, namez);
-    end_system_call();
-  });
+  if (consp(name)) {
+    with_string_0(Car(name),O(foreign_encoding),namez,
+      with_string_0(Cdr(name),O(foreign_encoding),verz, {
+        begin_system_call();
+        address = find_versioned_name(TheFpointer
+                                       (Car(Cdr(library)))->fp_pointer,
+                                       namez, verz);
+        end_system_call();
+    }););
+  } else {
+    with_string_0(name,O(foreign_encoding),namez, {
+      begin_system_call();
+      address = find_name(TheFpointer(Car(Cdr(library)))->fp_pointer, namez);
+      end_system_call();
+    });
+  }
   if (address == NULL) {
     pushSTACK(NIL);             /* 5 continue-format-string */
     pushSTACK(S(error));        /* 4 error type */
 <at>  <at>  -4439,7 +4472,7  <at>  <at> 
   }

 /* UP: find and allocate a foreign variable in a dynamic library
- > name     - variable C name (string - prechecked)
+ > name     - variable C name (string or (string . string) - prechecked)
  > library  - library C name (string - checked here)
  > offset   - address offset in the library or NIL
  > fvd      - function type
 <at>  <at>  -4468,7 +4501,7  <at>  <at> 
 }

 /* UP: find and allocate a foreign function in a dynamic library
- > name     - function C name (string - prechecked)
+ > name     - function C name (string or (string . string) - prechecked)
  > library  - library C name (string - checked here)
  > offset   - address offset in the library or NIL
  > properties - function properties
Index: clisp/src/foreign1.lisp
===================================================================
--- clisp.orig/src/foreign1.lisp        2008-03-11 17:24:42.000000000 -0800
+++ clisp/src/foreign1.lisp     2008-03-11 17:38:34.269200000 -0800
 <at>  <at>  -418,13 +418,18  <at>  <at> 
                   (setq *foreign-language* :STDC))))))))) ; Default is ANSI C

 (defun parse-foreign-name (name)
-  (unless (stringp name)
-    (error (TEXT "The name must be a string, not ~S")
-           name))
-  (if (c-ident-p name)
-    name
-    (error (TEXT "The name ~S is not a valid C identifier")
-           name)))
+  (flet ((check-c (name)
+           (unless (c-ident-p name)
+             (error (TEXT "The name ~S is not a valid C identifier")
+                    name))))
+    (cond
+      ((stringp name) (check-c name) name)
+      ((and (consp name)
+            (stringp (car name))
+            (stringp (cdr name)))
+       (check-c (car name)) name)
+      (t
+        (error (TEXT "The name must be a string or cons pair of
strings, not ~S"))))))

 (defmacro DEF-C-TYPE (&whole whole-form name &optional typespec)
   (setq name (check-symbol name (first whole-form)))

-------------------------------------------------------------------------
This SF.net email is sponsored by: Microsoft
Defy all challenges. Microsoft(R) Visual Studio 2008.
http://clk.atdmt.com/MRT/go/vse0120000070mrt/direct/01/

Gmane