src/code/foreign-load.lisp

   1 ;;;; Loading shared object files
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!ALIEN")
  13
  14 (define-unsupported-fun load-foreign
  15     "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  16   "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  17   (load-foreign))
  18
  19 (define-unsupported-fun load-1-foreign
  20     "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  21   "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  22   (load-1-foreign))
  23
  24 (define-alien-routine dlopen system-area-pointer
  25   (file c-string) (mode int))
  26
  27 (define-alien-routine dlclose int
  28   (handle system-area-pointer))
  29
  30 (define-alien-routine dlerror c-string)
  31
  32 (define-alien-routine dlsym system-area-pointer
  33   (handle system-area-pointer)
  34   (symbol c-string))
  35
  36 (defvar *runtime-dlhandle*)
  37 (defvar *shared-objects*)
  38
  39 (defstruct shared-object file sap)
  40
  41 (defun dlopen-or-lose (filename)
  42   (dlerror) ; clear old errors
  43   (let ((sap (dlopen filename (logior rtld-global rtld-now))))
  44     (when (zerop (sap-int sap))
  45       (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
  46              filename (dlerror)))
  47     sap))
  48
  49 (defun load-shared-object (file)
  50   "Load a shared library/dynamic shared object file/general
  51 dlopenable alien container.
  52
  53 To use LOAD-SHARED-OBJECT, at the Unix command line do this:
  54
  55  echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
  56  make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
  57  ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
  58
  59 Then in SBCL do this:
  60
  61  (load-shared-object \"/tmp/ffi-test.so\")
  62  (define-alien-routine summish int (x int) (y int))
  63
  64 Now running (summish 10 20) should return 31."
  65   (let* ((real-file (or (unix-namestring file) file))
  66          (sap (dlopen-or-lose real-file))
  67          (obj (make-shared-object :file real-file :sap sap)))
  68     (unless (member sap *shared-objects*
  69                     :test #'sap= :key #'shared-object-sap)
  70       (setf *shared-objects* (append *shared-objects* (list obj))))
  71     (pathname real-file)))
  72
  73 (defun try-reopen-shared-object (obj)
  74   (restart-case
  75       (let ((sap (dlopen-or-lose (shared-object-file obj))))
  76         (setf (shared-object-sap obj) sap)
  77         obj)
  78     (skip ()
  79       :report "Skip this shared object and continue. References to ~
  80                foreign symbols in this shared object will fail, ~
  81                causing potential corruption."
  82       *runtime-dlhandle*)))
  83
  84 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
  85 ;;; initialization.
  86 (defun reopen-shared-objects ()
  87   ;; Ensure that the runtime is present in the list
  88   (setf *runtime-dlhandle* (dlopen-or-lose nil)
  89         *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
  90
  91 ;;; Close all dlopened libraries and clear out sap entries in
  92 ;;; *SHARED-OBJECTS*.
  93 (defun close-shared-objects ()
  94   (dolist (obj (reverse *shared-objects*))
  95     (dlclose (shared-object-sap obj))
  96     (setf (shared-object-sap obj) nil))
  97   (dlclose *runtime-dlhandle*)
  98   (setf *runtime-dlhandle* nil))
  99
 100 (defun get-dynamic-foreign-symbol-address (symbol)
 101   (dlerror) ; clear old errors
 102   (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
 103         (err (dlerror)))
 104     (if (or (not (zerop result)) (not err))
 105         result
 106         (dolist (obj *shared-objects*)
 107           (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
 108                 err (dlerror))
 109           (when (or (not (zerop result)) (not err))
 110             (return result))))))